diff options
author | Kevin B Kenny <kennykb@acm.org> | 2005-02-02 15:53:08 (GMT) |
---|---|---|
committer | Kevin B Kenny <kennykb@acm.org> | 2005-02-02 15:53:08 (GMT) |
commit | 3c0515c337e167fca046dd00e93ed8b2854a5230 (patch) | |
tree | b43fda01c3d1ab7d76ccc32f883baeefad6ce632 | |
parent | bf8624b10b90162a40fbfd22728aa7400752eaf9 (diff) | |
download | tcl-3c0515c337e167fca046dd00e93ed8b2854a5230.zip tcl-3c0515c337e167fca046dd00e93ed8b2854a5230.tar.gz tcl-3c0515c337e167fca046dd00e93ed8b2854a5230.tar.bz2 |
sync with head, add TclStrToD (TIP #132)
44 files changed, 2417 insertions, 497 deletions
@@ -1,3 +1,123 @@ +2005-02-01 Kevin B. Kenny <kennykb@acm.org> + + [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' throughout 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. + + 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 <dgp@users.sourceforge.net> + + * generic/tclExecute.c (TclCompEvalObj): Removed stray statement + left behind in prior code reorganization. + +2005-01-31 Don Porter <dgp@users.sourceforge.net> + + * unix/configure: autoconf-2.57 + +2005-01-30 Joe English <jenglish@users.sourceforge.net> + + * 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 <jeffh@ActiveState.com> + + * unix/configure, unix/tcl.m4: add solaris 64-bit gcc build + support. [Bug 1021871] + +2005-01-28 Donal K. Fellows <donal.k.fellows@man.ac.uk> + + * tests/expr-old.test (expr-old-37.2): Added test for [Bug 1109484] + +2005-01-27 Jeff Hobbs <jeffh@ActiveState.com> + + * generic/tclBasic.c (Tcl_ExprBoolean, Tcl_ExprDouble) + (Tcl_ExprLong): Fix to recognize Tcl_WideInt type. [Bug 1109484] + +2005-01-26 Andreas Kupries <andreask@activestate.com> + + 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 <dgp@users.sourceforge.net> + + * 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 <das@users.sourceforge.net> + + * 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 <andreask@activestate.com> + + * 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 <andreask@activestate.com> + + * 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 <donal.k.fellows@man.ac.uk> + + * doc/FileSystem.3: Add missing ARGUMENTS section definitions for + arguments to Tcl_FSLink. [Bug 1106272] + 2005-01-21 Kevin B. Kenny <kennykb@acm.org> [kennykb-numerics-branch] diff --git a/doc/CrtChannel.3 b/doc/CrtChannel.3 index 779b755..4052435 100644 --- a/doc/CrtChannel.3 +++ b/doc/CrtChannel.3 @@ -5,13 +5,13 @@ '\" 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.1 2005/02/02 15:53:12 kennykb 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_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 <tcl.h>\fR @@ -99,6 +99,9 @@ Tcl_DriverSeekProc * .VS 8.4 Tcl_DriverWideSeekProc * \fBTcl_ChannelWideSeekProc\fR(\fItypePtr\fR) +.sp +Tcl_DriverThreadActionProc * +\fBTcl_ChannelThreadActionProc\fR(\fItypePtr\fR) .VE 8.4 .sp Tcl_DriverSetOptionProc * @@ -290,10 +293,20 @@ name is registered in the (thread)-global list of all channels (result (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 @@ -311,21 +324,22 @@ details about the old structure. The \fBTcl_ChannelType\fR structure contains the following fields: .CS typedef struct Tcl_ChannelType { - char *\fItypeName\fR; - Tcl_ChannelTypeVersion \fIversion\fR; - Tcl_DriverCloseProc *\fIcloseProc\fR; - Tcl_DriverInputProc *\fIinputProc\fR; - Tcl_DriverOutputProc *\fIoutputProc\fR; - Tcl_DriverSeekProc *\fIseekProc\fR; - Tcl_DriverSetOptionProc *\fIsetOptionProc\fR; - Tcl_DriverGetOptionProc *\fIgetOptionProc\fR; - Tcl_DriverWatchProc *\fIwatchProc\fR; - Tcl_DriverGetHandleProc *\fIgetHandleProc\fR; - Tcl_DriverClose2Proc *\fIclose2Proc\fR; - Tcl_DriverBlockModeProc *\fIblockModeProc\fR; - Tcl_DriverFlushProc *\fIflushProc\fR; - Tcl_DriverHandlerProc *\fIhandlerProc\fR; - Tcl_DriverWideSeekProc *\fIwideSeekProc\fR; + char *\fItypeName\fR; + Tcl_ChannelTypeVersion \fIversion\fR; + Tcl_DriverCloseProc *\fIcloseProc\fR; + Tcl_DriverInputProc *\fIinputProc\fR; + Tcl_DriverOutputProc *\fIoutputProc\fR; + Tcl_DriverSeekProc *\fIseekProc\fR; + Tcl_DriverSetOptionProc *\fIsetOptionProc\fR; + Tcl_DriverGetOptionProc *\fIgetOptionProc\fR; + Tcl_DriverWatchProc *\fIwatchProc\fR; + Tcl_DriverGetHandleProc *\fIgetHandleProc\fR; + Tcl_DriverClose2Proc *\fIclose2Proc\fR; + Tcl_DriverBlockModeProc *\fIblockModeProc\fR; + Tcl_DriverFlushProc *\fIflushProc\fR; + Tcl_DriverHandlerProc *\fIhandlerProc\fR; + Tcl_DriverWideSeekProc *\fIwideSeekProc\fR; + Tcl_DriverThreadActionProc *\fIthreadActionProc\fR; } Tcl_ChannelType; .CE .PP @@ -346,6 +360,7 @@ structure, the following functions should be used to obtain the values: \fBTcl_ChannelOutputProc\fR, \fBTcl_ChannelSeekProc\fR, .VS 8.4 \fBTcl_ChannelWideSeekProc\fR, +\fBTcl_ChannelThreadActionProc\fR, .VE 8.4 \fBTcl_ChannelSetOptionProc\fR, \fBTcl_ChannelGetOptionProc\fR, \fBTcl_ChannelWatchProc\fR, \fBTcl_ChannelGetHandleProc\fR, @@ -365,16 +380,25 @@ 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. +.VS 8.4 +\fBTCL_CHANNEL_VERSION_3\fR must be set to specifiy the \fIwideSeekProc\fR member. +.VE 8.4 +.VS 8.5 +\fBTCL_CHANNEL_VERSION_4\fR must be set to specifiy the +\fIthreadActionProc\fR member (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, +one of \fBTCL_CHANNEL_VERSION_4\fR, \fBTCL_CHANNEL_VERSION_3\fR, .VE 8.4 \fBTCL_CHANNEL_VERSION_2\fR or \fBTCL_CHANNEL_VERSION_1\fR. .SS BLOCKMODEPROC @@ -775,6 +799,36 @@ type of event occurred on this channel. .PP This value can be retrieved with \fBTcl_ChannelHandlerProc\fR, which returns a pointer to the function. + +.VS 8.4 +.SS "THREADACTIONPROC" +.PP +The \fthreadActionProc\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. +.VE 8.4 + .SH TCL_BADCHANNELOPTION .PP This procedure generates a "bad option" error message in an diff --git a/doc/FileSystem.3 b/doc/FileSystem.3 index 1781a34..19d1aeb 100644 --- a/doc/FileSystem.3 +++ b/doc/FileSystem.3 @@ -4,7 +4,7 @@ '\" 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.1 2005/02/02 15:53:12 kennykb Exp $ '\" .so man.macros .TH Filesystem 3 8.4 Tcl "Tcl Library Procedures" @@ -228,6 +228,17 @@ The base path on to which to join the given elements. May be NULL. 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 diff --git a/doc/GetTime.3 b/doc/GetTime.3 index 7941379..22ffc53 100644 --- a/doc/GetTime.3 +++ b/doc/GetTime.3 @@ -16,10 +16,33 @@ Tcl_GetTime \- get date and time \fB#include <tcl.h>\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 @@ -47,6 +70,32 @@ 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 diff --git a/generic/tcl.decls b/generic/tcl.decls index 7c5862b..db39a1a 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: tcl.decls,v 1.105.2.4 2005/01/20 19:12:29 kennykb Exp $ +# RCS: @(#) $Id: tcl.decls,v 1.105.2.5 2005/02/02 15:53:14 kennykb Exp $ library tcl @@ -1973,19 +1973,34 @@ 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 552 generic { +declare 555 generic { Tcl_Obj* Tcl_NewBignumObj( mp_int* value ) } -declare 553 generic { +declare 556 generic { Tcl_Obj* Tcl_DbNewBignumObj( mp_int* value, CONST char* file, int line ) } -declare 554 generic { +declare 557 generic { void Tcl_SetBignumObj( Tcl_Obj* obj, mp_int* value ) } -declare 555 generic { +declare 558 generic { int Tcl_GetBignumFromObj( Tcl_Interp* interp, Tcl_Obj* obj, mp_int* value ) } diff --git a/generic/tcl.h b/generic/tcl.h index ac3468f..e1934e8 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tcl.h,v 1.191.2.5 2005/01/20 19:12:32 kennykb Exp $ + * RCS: @(#) $Id: tcl.h,v 1.191.2.6 2005/02/02 15:53:15 kennykb Exp $ */ #ifndef _TCL @@ -1425,6 +1425,11 @@ typedef struct 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 @@ -1463,6 +1468,14 @@ typedef int (Tcl_WaitForEventProc) _ANSI_ARGS_((Tcl_Time *timePtr)); #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: @@ -1498,6 +1511,9 @@ 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)); /* * The following declarations either map ckalloc and ckfree to @@ -1588,6 +1604,16 @@ typedef struct Tcl_ChannelType { * 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 + */ + Tcl_DriverThreadActionProc *threadActionProc; + /* Procedure to call to notify + * the driver of thread specific + * activity for a channel. + * May be NULL. */ } Tcl_ChannelType; /* diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 42874c5..c1bc9ac 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclBasic.c,v 1.136.2.2 2005/01/20 19:12:35 kennykb Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.136.2.3 2005/02/02 15:53:15 kennykb Exp $ */ #include "tclInt.h" @@ -3882,11 +3882,29 @@ Tcl_ExprLong(interp, string, ptr) /* * Store an integer based on the expression result. */ - + if (resultPtr->typePtr == &tclIntType) { *ptr = resultPtr->internalRep.longValue; } else if (resultPtr->typePtr == &tclDoubleType) { *ptr = (long) resultPtr->internalRep.doubleValue; + } else if (resultPtr->typePtr == &tclWideIntType) { +#ifndef TCL_WIDE_INT_IS_LONG + /* + * See Tcl_GetIntFromObj for conversion comments. + */ + Tcl_WideInt w = resultPtr->internalRep.wideValue; + if ((w >= -(Tcl_WideInt)(ULONG_MAX)) + && (w <= (Tcl_WideInt)(ULONG_MAX))) { + *ptr = Tcl_WideAsLong(w); + } else { + Tcl_SetResult(interp, + "integer value too large to represent as non-long integer", + TCL_STATIC); + result = TCL_ERROR; + } +#else + *ptr = resultPtr->internalRep.longValue; +#endif } else { Tcl_SetResult(interp, "expression didn't have numeric value", TCL_STATIC); @@ -3932,11 +3950,29 @@ Tcl_ExprDouble(interp, string, ptr) /* * Store a double based on the expression result. */ - + if (resultPtr->typePtr == &tclIntType) { *ptr = (double) resultPtr->internalRep.longValue; } else if (resultPtr->typePtr == &tclDoubleType) { *ptr = resultPtr->internalRep.doubleValue; + } else if (resultPtr->typePtr == &tclWideIntType) { +#ifndef TCL_WIDE_INT_IS_LONG + /* + * See Tcl_GetIntFromObj for conversion comments. + */ + Tcl_WideInt w = resultPtr->internalRep.wideValue; + if ((w >= -(Tcl_WideInt)(ULONG_MAX)) + && (w <= (Tcl_WideInt)(ULONG_MAX))) { + *ptr = (double) Tcl_WideAsLong(w); + } else { + Tcl_SetResult(interp, + "integer value too large to represent as non-long integer", + TCL_STATIC); + result = TCL_ERROR; + } +#else + *ptr = (double) resultPtr->internalRep.longValue; +#endif } else { Tcl_SetResult(interp, "expression didn't have numeric value", TCL_STATIC); @@ -3982,11 +4018,17 @@ Tcl_ExprBoolean(interp, string, ptr) /* * 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 if (resultPtr->typePtr == &tclWideIntType) { +#ifndef TCL_WIDE_INT_IS_LONG + *ptr = (resultPtr->internalRep.wideValue != 0); +#else + *ptr = (resultPtr->internalRep.longValue != 0); +#endif } else { result = Tcl_GetBooleanFromObj(interp, resultPtr, ptr); } @@ -4642,7 +4684,7 @@ Tcl_AllowExceptions(interp) /* *---------------------------------------------------------------------- * - * 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 diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 108ea72..bd24024 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdAH.c,v 1.57 2004/11/13 00:19:07 dgp Exp $ + * RCS: @(#) $Id: tclCmdAH.c,v 1.57.2.1 2005/02/02 15:53:17 kennykb Exp $ */ #include "tclInt.h" @@ -374,7 +374,7 @@ Tcl_ConcatObjCmd(dummy, interp, objc, objv) /* *---------------------------------------------------------------------- * - * Tcl_ContinueObjCmd - + * Tcl_ContinueObjCmd -- * * This procedure is invoked to process the "continue" Tcl command. * See the user documentation for details on what it does. diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 03a4ccb..24cca7c 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -15,7 +15,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdMZ.c,v 1.115 2004/10/21 15:19:46 dgp Exp $ + * RCS: @(#) $Id: tclCmdMZ.c,v 1.115.2.1 2005/02/02 15:53:17 kennykb Exp $ */ #include "tclInt.h" @@ -1505,7 +1505,7 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) } } errno = 0; - strtod(string1, &stop); /* INTL: Tcl source. */ + TclStrToD(string1, (CONST char **) &stop); /* INTL: Tcl source. */ if (errno == ERANGE) { /* * if (errno == ERANGE), then it was an over/underflow diff --git a/generic/tclDecls.h b/generic/tclDecls.h index adb646b..8dacbb6 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclDecls.h,v 1.107.2.3 2005/01/20 19:12:51 kennykb Exp $ + * RCS: @(#) $Id: tclDecls.h,v 1.107.2.4 2005/02/02 15:53:18 kennykb Exp $ */ #ifndef _TCLDECLS @@ -3436,26 +3436,48 @@ 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 -/* 552 */ +/* 555 */ EXTERN Tcl_Obj* Tcl_NewBignumObj _ANSI_ARGS_((mp_int* value)); #endif #ifndef Tcl_DbNewBignumObj_TCL_DECLARED #define Tcl_DbNewBignumObj_TCL_DECLARED -/* 553 */ +/* 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 -/* 554 */ +/* 557 */ EXTERN void Tcl_SetBignumObj _ANSI_ARGS_((Tcl_Obj* obj, mp_int* value)); #endif #ifndef Tcl_GetBignumFromObj_TCL_DECLARED #define Tcl_GetBignumFromObj_TCL_DECLARED -/* 555 */ +/* 558 */ EXTERN int Tcl_GetBignumFromObj _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj* obj, mp_int* value)); #endif @@ -4052,10 +4074,13 @@ typedef struct TclStubs { 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 */ - Tcl_Obj* (*tcl_NewBignumObj) _ANSI_ARGS_((mp_int* value)); /* 552 */ - Tcl_Obj* (*tcl_DbNewBignumObj) _ANSI_ARGS_((mp_int* value, CONST char* file, int line)); /* 553 */ - void (*tcl_SetBignumObj) _ANSI_ARGS_((Tcl_Obj* obj, mp_int* value)); /* 554 */ - int (*tcl_GetBignumFromObj) _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj* obj, mp_int* value)); /* 555 */ + void (*tcl_SetTimeProc) _ANSI_ARGS_((Tcl_GetTimeProc* getProc, Tcl_ScaleTimeProc* scaleProc, ClientData clientData)); /* 552 */ + void (*tcl_QueryTimeProc) _ANSI_ARGS_((Tcl_GetTimeProc** getProc, Tcl_ScaleTimeProc** scaleProc, ClientData* clientData)); /* 553 */ + Tcl_DriverThreadActionProc * (*tcl_ChannelThreadActionProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 554 */ + Tcl_Obj* (*tcl_NewBignumObj) _ANSI_ARGS_((mp_int* value)); /* 555 */ + Tcl_Obj* (*tcl_DbNewBignumObj) _ANSI_ARGS_((mp_int* value, CONST char* file, int line)); /* 556 */ + void (*tcl_SetBignumObj) _ANSI_ARGS_((Tcl_Obj* obj, mp_int* value)); /* 557 */ + int (*tcl_GetBignumFromObj) _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj* obj, mp_int* value)); /* 558 */ } TclStubs; #ifdef __cplusplus @@ -6304,21 +6329,33 @@ extern TclStubs *tclStubsPtr; #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) /* 552 */ + (tclStubsPtr->tcl_NewBignumObj) /* 555 */ #endif #ifndef Tcl_DbNewBignumObj #define Tcl_DbNewBignumObj \ - (tclStubsPtr->tcl_DbNewBignumObj) /* 553 */ + (tclStubsPtr->tcl_DbNewBignumObj) /* 556 */ #endif #ifndef Tcl_SetBignumObj #define Tcl_SetBignumObj \ - (tclStubsPtr->tcl_SetBignumObj) /* 554 */ + (tclStubsPtr->tcl_SetBignumObj) /* 557 */ #endif #ifndef Tcl_GetBignumFromObj #define Tcl_GetBignumFromObj \ - (tclStubsPtr->tcl_GetBignumFromObj) /* 555 */ + (tclStubsPtr->tcl_GetBignumFromObj) /* 558 */ #endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 33f9249..b2de1e4 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclExecute.c,v 1.167.2.1 2004/12/29 22:46:42 kennykb Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.167.2.2 2005/02/02 15:53:21 kennykb Exp $ */ #include "tclInt.h" @@ -1008,7 +1008,6 @@ TclCompEvalObj(interp, objPtr) iPtr->numLevels--; return result; } - iPtr->evalFlags = 0; codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; } else { /* diff --git a/generic/tclFileName.c b/generic/tclFileName.c index a89497d..54fd83b 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclFileName.c,v 1.60.2.1 2005/01/20 14:53:39 kennykb Exp $ + * RCS: @(#) $Id: tclFileName.c,v 1.60.2.2 2005/02/02 15:53:23 kennykb Exp $ */ #include "tclInt.h" @@ -2308,7 +2308,7 @@ DoGlob(interp, matchesObj, separators, pathPtr, flags, pattern, types) /* *--------------------------------------------------------------------------- * - * 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 diff --git a/generic/tclGet.c b/generic/tclGet.c index 1fd6277..b37653f 100644 --- a/generic/tclGet.c +++ b/generic/tclGet.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclGet.c,v 1.9 2004/04/06 22:25:51 dgp Exp $ + * RCS: @(#) $Id: tclGet.c,v 1.9.2.1 2005/02/02 15:53:24 kennykb Exp $ */ #include "tclInt.h" @@ -220,11 +220,11 @@ Tcl_GetDouble(interp, string, doublePtr) * in a form acceptable to strtod. */ double *doublePtr; /* Place to store converted result. */ { - char *end; + CONST char *end; double d; errno = 0; - d = strtod(string, &end); /* INTL: Tcl source. */ + d = TclStrToD(string, &end); /* INTL: Tcl source. */ if (end == string) { badDouble: if (interp != (Tcl_Interp *) NULL) { diff --git a/generic/tclIO.c b/generic/tclIO.c index bb6c438..a043475 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIO.c,v 1.81 2004/11/30 19:34:47 dgp Exp $ + * RCS: @(#) $Id: tclIO.c,v 1.81.2.1 2005/02/02 15:53:24 kennykb Exp $ */ #include "tclInt.h" @@ -1205,18 +1205,19 @@ Tcl_CreateChannel(typePtr, chanName, instanceData, mask) * in the list on exit. * * JH: Could call Tcl_SpliceChannel, but need to avoid NULL check. + * + * 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 = 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(); + statePtr->nextCSPtr = (ChannelState *) NULL; + Tcl_SpliceChannel ((Tcl_Channel) chanPtr); /* * Install this channel in the first empty standard channel slot, if @@ -2382,7 +2383,7 @@ CloseChannel(interp, chanPtr, errorCode) * Resets the field 'nextCSPtr' of the specified channel state to NULL. * * NOTE: - * The channel to splice out of the list must not be referenced + * 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 @@ -2404,6 +2405,7 @@ Tcl_CutChannel(chan) * 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 @@ -2426,8 +2428,12 @@ Tcl_CutChannel(chan) statePtr->nextCSPtr = (ChannelState *) NULL; - TclpCutFileChannel(chan); - TclpCutSockChannel(chan); + /* TIP #218, Channel Thread Actions */ + threadActionProc = Tcl_ChannelThreadActionProc (Tcl_GetChannelType (chan)); + if (threadActionProc != NULL) { + (*threadActionProc) (Tcl_GetChannelInstanceData(chan), + TCL_CHANNEL_THREAD_REMOVE); + } } /* @@ -2446,7 +2452,7 @@ Tcl_CutChannel(chan) * Nothing. * * NOTE: - * The channel to add to the list must not be referenced in any + * 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) @@ -2462,8 +2468,9 @@ Tcl_SpliceChannel(chan) * not be referenced in any * interpreter. */ { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - ChannelState *statePtr = ((Channel *) chan)->state; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + ChannelState *statePtr = ((Channel *) chan)->state; + Tcl_DriverThreadActionProc *threadActionProc; if (statePtr->nextCSPtr != (ChannelState *) NULL) { Tcl_Panic("Tcl_SpliceChannel: trying to add channel used in different list"); @@ -2480,8 +2487,12 @@ Tcl_SpliceChannel(chan) statePtr->managingThread = Tcl_GetCurrentThread(); - TclpSpliceFileChannel(chan); - TclpSpliceSockChannel(chan); + /* TIP #218, Channel Thread Actions */ + threadActionProc = Tcl_ChannelThreadActionProc (Tcl_GetChannelType (chan)); + if (threadActionProc != NULL) { + (*threadActionProc) (Tcl_GetChannelInstanceData(chan), + TCL_CHANNEL_THREAD_INSERT); + } } /* @@ -8953,6 +8964,8 @@ Tcl_ChannelVersion(chanTypePtr) 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 <v2 channel versions, the version field is occupied @@ -9308,6 +9321,34 @@ Tcl_ChannelWideSeekProc(chanTypePtr) } } +/* + *---------------------------------------------------------------------- + * + * 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; + } +} + #if 0 /* * For future debugging work, a simple function to print the flags of diff --git a/generic/tclInt.h b/generic/tclInt.h index 91398cf..a6e7bb3 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclInt.h,v 1.202.2.4 2005/01/20 19:13:22 kennykb Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.202.2.5 2005/02/02 15:53:26 kennykb Exp $ */ #ifndef _TCLINT @@ -1742,6 +1742,14 @@ 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. */ @@ -1969,10 +1977,6 @@ MODULE_SCOPE Tcl_Obj* TclpObjLink _ANSI_ARGS_((Tcl_Obj *pathPtr, 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, @@ -2006,6 +2010,8 @@ MODULE_SCOPE void TclSetProcessGlobalValue _ANSI_ARGS_ (( Tcl_Encoding encoding)); MODULE_SCOPE VOID TclSignalExitThread _ANSI_ARGS_((Tcl_ThreadId id, int result)); +MODULE_SCOPE double TclStrToD _ANSI_ARGS_((CONST char* string, + CONST char** endPtr)); MODULE_SCOPE int TclSubstTokens _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Token *tokenPtr, int count, int *tokensLeftPtr)); diff --git a/generic/tclObj.c b/generic/tclObj.c index c24377b..6419c73 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclObj.c,v 1.72.2.3 2005/01/20 21:19:44 kennykb Exp $ + * RCS: @(#) $Id: tclObj.c,v 1.72.2.4 2005/02/02 15:53:26 kennykb Exp $ */ #include "tclInt.h" @@ -1419,7 +1419,7 @@ SetBooleanFromAny(interp, objPtr) * NULLs. */ - dbl = strtod(string, &end); + dbl = TclStrToD(string, (CONST char **) &end); if (end == string) { goto badBoolean; } @@ -1705,7 +1705,7 @@ SetDoubleFromAny(interp, objPtr) Tcl_Interp *interp; /* Used for error reporting if not NULL. */ register Tcl_Obj *objPtr; /* The object to convert. */ { - char *string, *end; + CONST char *string, *end; double newDouble; int length; @@ -1722,7 +1722,7 @@ SetDoubleFromAny(interp, objPtr) */ errno = 0; - newDouble = strtod(string, &end); + newDouble = TclStrToD(string, &end); if (end == string) { badDouble: if (interp != NULL) { diff --git a/generic/tclParseExpr.c b/generic/tclParseExpr.c index 2a1c151..adad73f 100644 --- a/generic/tclParseExpr.c +++ b/generic/tclParseExpr.c @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclParseExpr.c,v 1.23 2004/10/08 15:39:55 dkf Exp $ + * RCS: @(#) $Id: tclParseExpr.c,v 1.23.2.1 2005/02/02 15:53:27 kennykb Exp $ */ #include "tclInt.h" @@ -1666,14 +1666,15 @@ GetLexeme(infoPtr) * so we can set an terminating NULL to keep strtod from * scanning too far. */ - char *startPtr, *termPtr; + char *startPtr; + CONST char *termPtr; double doubleValue; Tcl_DString toParse; errno = 0; Tcl_DStringInit(&toParse); startPtr = Tcl_DStringAppend(&toParse, src, length); - doubleValue = strtod(startPtr, &termPtr); + doubleValue = TclStrToD(startPtr, &termPtr); Tcl_DStringFree(&toParse); if (termPtr != startPtr) { if (errno != 0) { diff --git a/generic/tclScan.c b/generic/tclScan.c index 624910c..f07e1c3 100644 --- a/generic/tclScan.c +++ b/generic/tclScan.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclScan.c,v 1.16 2004/10/06 15:59:25 dgp Exp $ + * RCS: @(#) $Id: tclScan.c,v 1.16.2.1 2005/02/02 15:53:27 kennykb Exp $ */ #include "tclInt.h" @@ -1144,7 +1144,7 @@ Tcl_ScanObjCmd(dummy, interp, objc, objv) if (!(flags & SCAN_SUPPRESS)) { double dvalue; *end = '\0'; - dvalue = strtod(buf, NULL); + dvalue = TclStrToD(buf, NULL); objPtr = Tcl_NewDoubleObj(dvalue); Tcl_IncrRefCount(objPtr); objs[objIndex++] = objPtr; diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c new file mode 100755 index 0000000..d8d677f --- /dev/null +++ b/generic/tclStrToD.c @@ -0,0 +1,863 @@ +/* + *---------------------------------------------------------------------- + * + * tclStrToD.c -- + * + * This file contains a TclStrToD procedure that handles conversion + * of string to double, with correct rounding even where extended + * precision is needed to achieve that. + * + * 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.1 2005/02/02 15:53:27 kennykb Exp $ + */ + +#include <tclInt.h> +#include <stdio.h> +#include <stdlib.h> +#include <float.h> +#include <limits.h> +#include <math.h> +#include <ctype.h> +#include <tommath.h> + +#if ( FLT_RADIX == 2 ) && ( DBL_MANT_DIG == 53 ) && ( DBL_MAX_EXP == 1024 ) +#define IEEE_FLOATING_POINT +#endif + +TCL_DECLARE_MUTEX( initMutex ); + +/* The powers of ten that can be represented exactly as IEEE754 doubles. */ + +#define MAXPOW 22 +static double pow10 [MAXPOW+1]; + +/* 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 +}; + +/* Flag for whether the constants have been initialized */ + +static volatile int constantsInitialized = 0; + +/* 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]; + +/* Static functions defined in this file */ + +static void InitializeConstants _ANSI_ARGS_((void)); +static void FreeConstants _ANSI_ARGS_((ClientData)); +static double RefineResult _ANSI_ARGS_((double approx, CONST char* start, + int nDigits, long exponent)); +static double BignumToDouble _ANSI_ARGS_(( mp_int* a )); +static double ParseNaN _ANSI_ARGS_(( int signum, CONST char** end )); + +/* + *---------------------------------------------------------------------- + * + * TclStrToD -- + * + * Scans a double from a string. + * + * Results: + * Returns the scanned number. In the case of underflow, returns + * an appropriately signed zero; in the case of overflow, returns + * an appropriately signed HUGE_VAL. + * + * Side effects: + * Stores a pointer to the end of the scanned number in '*endPtr', + * if endPtr is not NULL. If '*endPtr' is equal to 's' on return from + * this function, it indicates that the input string could not be + * recognized as a number. + * In the case of underflow or overflow, 'errno' is set to ERANGE. + * + *------------------------------------------------------------------------ + */ + +double +TclStrToD( CONST char* s, + /* String to scan */ + CONST char ** endPtr ) + /* Pointer to the end of the scanned number */ +{ + + CONST char* p = s; + CONST char* startOfSignificand = NULL; + /* Start of the significand in the + * string */ + int signum = 0; /* Sign of the significand */ + double exactSignificand = 0.0; + /* Significand, represented exactly + * as a floating-point number */ + int seenDigit = 0; /* Flag == 1 if a digit has been seen */ + int nSigDigs = 0; /* Number of significant digits presented */ + int nDigitsAfterDp = 0; /* Number of digits after the decimal point */ + int nTrailZero = 0; /* Number of trailing zeros in the + * significand */ + long exponent = 0; /* Exponent */ + int seenDp = 0; /* Flag == 1 if decimal point has been seen */ + + char c; /* One character extracted from the input */ + + static int mmaxpow = 0; /* Largest power of ten that can be + * represented exactly in a 'double'. */ + double v; /* Scanned value */ + int machexp; /* Exponent of the machine rep of the + * scanned value */ + int expt2; /* Exponent for computing first + * approximation to the true value */ + int i, j; + + InitializeConstants(); + + if ( mmaxpow == 0 ) { + int x = (int) (DBL_MANT_DIG * log((double) FLT_RADIX) / log( 5.0 )) + - 1; + if ( x < MAXPOW ) { + mmaxpow = x; + } else { + mmaxpow = MAXPOW; + } + } + + /* Discard leading whitespace */ + + while ( isspace( *p ) ) { + ++p; + } + + /* Determine the sign of the significand */ + + switch( *p ) { + case '-': + signum = 1; + /* FALLTHROUGH */ + case '+': + ++p; + } + + /* Discard leading zeroes */ + + while ( *p == '0' ) { + seenDigit = 1; + ++p; + } + + /* + * Scan digits from the significand. Simultaneously, keep track + * of the number of digits after the decimal point. Maintain + * a pointer to the start of the significand. Keep "exactSignificand" + * equal to the conversion of the DBL_DIG most significant digits. + */ + + for ( ; ; ) { + c = *p; + if ( c == '.' && !seenDp ) { + seenDp = 1; + ++p; + } else if ( isdigit(c) ) { + if ( c == '0' ) { + if ( startOfSignificand != NULL ) { + ++nTrailZero; + } + } else { + if ( startOfSignificand == NULL ) { + startOfSignificand = p; + } else if ( nTrailZero ) { + if ( nTrailZero + nSigDigs < DBL_DIG ) { + exactSignificand *= pow10[ nTrailZero ]; + } else if ( nSigDigs < DBL_DIG ) { + exactSignificand *= pow10[ DBL_DIG - nSigDigs ]; + } + nSigDigs += nTrailZero; + } + if ( nSigDigs < DBL_DIG ) { + exactSignificand = 10. * exactSignificand + (c - '0'); + } + ++nSigDigs; + nTrailZero = 0; + } + if ( seenDp ) { + ++nDigitsAfterDp; + } + seenDigit = 1; + ++p; + } else { + break; + } + } + + /* + * At this point, we've scanned the significand, and p points + * to the character beyond it. "startOfSignificand" is the first + * non-zero character in the significand. "nSigDigs" is the number + * of significant digits of the significand, not including any + * trailing zeroes. "exactSignificand" is a floating point number + * that represents, without loss of precision, the first + * min(DBL_DIG,n) digits of the significand. "nDigitsAfterDp" + * is the number of digits after the decimal point, again excluding + * trailing zeroes. + * + * Now scan 'E' format + */ + + exponent = 0; + if ( seenDigit && ( *p == 'e' || *p == 'E' ) ) { + CONST char* stringSave = p; + ++p; + c = *p; + if ( isdigit( c ) || c == '+' || c == '-' ) { + exponent = strtol( p, (char**)&p, 10 ); + } + if ( p == stringSave + 1 ) { + p = stringSave; + exponent = 0; + } + } + + exponent = exponent + nTrailZero - nDigitsAfterDp; + + if ( !seenDigit ) { + + /* Test for Inf */ + + if ( c == 'I' || c == 'i' ) { + + if ( ( p[1] == 'N' || p[1] == 'n' ) + && ( p[2] == 'F' || p[2] == 'f' ) ) { + p += 3; + if ( ( p[0] == 'I' || p[0] == 'i' ) + && ( p[1] == 'N' || p[1] == 'n' ) + && ( p[2] == 'I' || p[2] == 'i' ) + && ( p[3] == 'T' || p[3] == 't' ) + && ( p[4] == 'Y' || p[1] == 'y' ) ) { + p += 5; + } + errno = ERANGE; + v = HUGE_VAL; + if ( endPtr != NULL ) { + *endPtr = p; + } + goto returnValue; + } + + +#ifdef IEEE_FLOATING_POINT + + /* IEEE floating point supports NaN */ + + } else if ( (c == 'N' || c == 'n' ) + && ( sizeof(Tcl_WideUInt) == sizeof( double ) ) ) { + + if ( ( p[1] == 'A' || p[1] == 'a' ) + && ( p[2] == 'N' || p[2] == 'n' ) ) { + p += 3; + + if ( endPtr != NULL ) { + *endPtr = p; + } + + return ParseNaN( signum, endPtr ); + + } +#endif + + } + + goto error; + } + + if ( endPtr != NULL ) { + *endPtr = p; + } + + /* Test for zero. */ + + if ( nSigDigs == 0 ) { + v = 0.0; + goto returnValue; + } + + /* + * The easy cases are where we have an exact significand and + * the exponent is small enough that we can compute the value + * with only one roundoff. The code below that is surrounded + * with #if 0 corresponds to cases that Gay and Clinger claim + * function correctly. but have been observed to fail on mingw, + * returning some results that are off by 1 ulp. + * (Oddly enough, they function correctly on VC++6 on the same + * machine - and they pretty obviously are computing the products + * and quotients of exact floating point numbers.) + */ + + if ( nSigDigs <= DBL_DIG ) { + if ( exponent >= 0 ) { + if ( exponent <= mmaxpow ) { + v = exactSignificand * pow10[ exponent ]; + goto returnValue; + } else { +#if 0 + int diff = DBL_DIG - nSigDigs; + if ( exponent - diff <= mmaxpow ) { + volatile double factor = exactSignificand * pow10[ diff ]; + v = factor * pow10[ exponent - diff ]; + goto returnValue; + } +#endif + } + } else { +#if 0 + if ( exponent >= -mmaxpow ) { + v = exactSignificand / pow10[ -exponent ]; + goto returnValue; + } +#endif + } + } + + /* + * We don't have one of the easy cases, so we can't compute the + * scanned number exactly, and have to do it in multiple precision. + * Begin by testing for obvious overflows and underflows. + */ + + if ( nSigDigs + exponent - 1 + > DBL_MAX_EXP * log( (double) FLT_RADIX ) / log( 10. ) ) { + v = HUGE_VAL; + errno = ERANGE; + goto returnValue; + } + if ( nSigDigs + exponent - 1 + < floor ( ( DBL_MIN_EXP - DBL_MANT_DIG ) + * log( (double) FLT_RADIX ) / log( 10. ) ) ) { + v = 0.; + goto returnValue; + } + + /* + * Nothing exceeds the boundaries of the tables, at least. + * Compute an approximate value for the number, with + * no possibility of overflow because we manage the exponent + * separately. + */ + + if ( nSigDigs > DBL_DIG ) { + expt2 = exponent + nSigDigs - DBL_DIG; + } else { + expt2 = exponent; + } + v = frexp( exactSignificand, &machexp ); + if ( expt2 > 0 ) { + v = frexp( v * pow10[ expt2 & 0xf ], &j ); + machexp += j; + for ( i = 4; i < 9; ++i ) { + if ( expt2 & ( 1 << i ) ) { + v = frexp( v * pow_10_2_n[ i ], &j ); + machexp += j; + } + } + } else { + v = frexp( v / pow10[ (-expt2) & 0xf ], &j ); + machexp += j; + for ( i = 4; i < 9; ++i ) { + if ( (-expt2) & ( 1 << i ) ) { + v = frexp( v / pow_10_2_n[ i ], &j ); + machexp += j; + } + } + } + + /* + * A first approximation is that the result will be v * 2 ** machexp. + * v is greater than or equal to 0.5 and less than 1. + * If machexp > DBL_MAX_EXP * log2(FLT_RADIX), there is an overflow. + */ + + if ( machexp > DBL_MAX_EXP * log2FLT_RADIX ) { + v = HUGE_VAL; + errno = ERANGE; + goto returnValue; + } + + v = ldexp( v, machexp ); + if ( v == 0 ) { + /* DBL_MIN is known to be incorrect on MSVC6, and ldexp + * doesn't work with denormals. */ + v = ldexp( 1.0, DBL_MIN_EXP * log2FLT_RADIX ); + v *= ldexp( 1.0, (-DBL_MANT_DIG) * log2FLT_RADIX ); + } + + /* + * We have a first approximation in v. Now we need to refine it. + */ + + v = RefineResult( v, startOfSignificand, nSigDigs, exponent ); + + /* In a very few cases, a second iteration is needed. e.g., 457e-102 */ + + v = RefineResult( v, startOfSignificand, nSigDigs, exponent ); + + /* Handle underflow */ + + returnValue: + if ( nSigDigs != 0 && v == 0.0 ) { + errno = ERANGE; + } + + /* Return a number with correct sign */ + + if ( signum ) { + return -v; + } else { + return v; + } + + + /* Come here on an invalid input */ + + error: + if ( endPtr != NULL ) { + *endPtr = s; + } + return 0.0; +} + +/* + *---------------------------------------------------------------------- + * + * InitializeConstants -- + * + * Initializes constants that are needed for string-to-double + * conversion. + * + * 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. + * + *---------------------------------------------------------------------- + */ + +static void +InitializeConstants( void ) +{ + int i; + double d; + if ( !constantsInitialized ) { + Tcl_MutexLock( &initMutex ); + if ( !constantsInitialized ) { + frexp( (double) FLT_RADIX, &log2FLT_RADIX ); + --log2FLT_RADIX; + mantBits = DBL_MANT_DIG * log2FLT_RADIX; + d = 1.0; + for ( i = 0; i <= MAXPOW; ++i ) { + pow10[i] = d; + d *= 10.0; + } + for ( i = 0; i < 9; ++i ) { + mp_init( pow5 + i ); + } + mp_set( pow5, 5 ); + for ( i = 0; i < 8; ++i ) { + mp_sqr( pow5+i, pow5+i+1 ); + } + Tcl_CreateExitHandler( FreeConstants, (ClientData) NULL ); + } + constantsInitialized = 1; + Tcl_MutexUnlock( &initMutex ); + } +} + +/* + *---------------------------------------------------------------------- + * + * FreeConstants -- + * + * Cleans up this file on exit. + * + * Results: + * None + * + * Side effects: + * Memory allocated by InitializeConstants is freed. + * + *---------------------------------------------------------------------- + */ + +static void +FreeConstants( ClientData unused ) +{ + int i; + Tcl_MutexLock( &initMutex ); + constantsInitialized = 0; + for ( i = 0; i < 9; ++i ) { + mp_clear( pow5 + i ); + } + Tcl_MutexUnlock( &initMutex ); +} + +/* + *---------------------------------------------------------------------- + * + * RefineResult -- + * + * Given a poor approximation to a floating point number, returns + * a better one (The better approximation is correct to within + * 1 ulp, and is entirely correct if the poor approximation is + * correct to 1 ulp.) + * + * Results: + * Returns the improved result. + * + *---------------------------------------------------------------------- + */ + +static double +RefineResult( double approxResult, + /* Approximate result of conversion */ + CONST char* sigStart, + /* Pointer to start of significand in + * input string. */ + int nSigDigs, /* Number of significant digits */ + long exponent ) /* Power of ten to multiply by significand */ +{ + + int M2, M5; /* Powers of 2 and of 5 needed to put + * the decimal and binary numbers over + * a common denominator. */ + double significand; /* Sigificand of the binary number */ + int binExponent; /* Exponent of the binary number */ + + int msb; /* Most significant bit position of an + * intermediate result */ + int nDigits; /* Number of mp_digit's in an intermediate + * result */ + mp_int twoMv; /* Approx binary value expressed as an + * exact integer scaled by the multiplier 2M */ + mp_int twoMd; /* Exact decimal value expressed as an + * exact integer scaled by the multiplier 2M */ + int scale; /* Scale factor for M */ + int multiplier; /* Power of two to scale M */ + double num, den; /* Numerator and denominator of the + * correction term */ + double quot; /* Correction term */ + double minincr; /* Lower bound on the absolute value + * of the correction term. */ + int i; + CONST char* p; + + /* + * Find a common denominator for the decimal and binary fractions. + * The common denominator will be 2**M2 + 5**M5. + */ + + significand = frexp( approxResult, &binExponent ); + i = mantBits - binExponent; + if ( i < 0 ) { + M2 = 0; + } else { + M2 = i; + } + if ( exponent > 0 ) { + M5 = 0; + } else { + M5 = -exponent; + if ( (M5-1) > M2 ) { + M2 = M5-1; + } + } + + /* + * The floating point number is significand*2**binExponent. + * The 2**-1 bit of the significand (the most significant) + * corresponds to the 2**(binExponent+M2 + 1) bit of 2*M2*v. + * Allocate enough digits to hold that quantity, then + * convert the significand to a large integer, scaled + * appropriately. Then multiply by the appropriate power of 5. + */ + + msb = binExponent + M2; /* 1008 */ + nDigits = msb / DIGIT_BIT + 1; + mp_init_size( &twoMv, nDigits ); + i = ( msb % DIGIT_BIT + 1 ); + twoMv.used = nDigits; + significand *= ldexp( 1.0, i ); + while ( -- nDigits >= 0 ) { + twoMv.dp[nDigits] = (mp_digit) significand; + significand -= (mp_digit) significand; + significand = ldexp( significand, DIGIT_BIT ); + } + for ( i = 0; i <= 8; ++i ) { + if ( M5 & ( 1 << i ) ) { + mp_mul( &twoMv, pow5+i, &twoMv ); + } + } + + /* + * Collect the decimal significand as a high precision integer. + * The least significant bit corresponds to bit M2+exponent+1 + * so it will need to be shifted left by that many bits after + * being multiplied by 5**(M5+exponent). + */ + + mp_init( &twoMd ); mp_zero( &twoMd ); + i = nSigDigs; + for ( p = sigStart ; ; ++p ) { + char c = *p; + if ( isdigit( c ) ) { + mp_mul_d( &twoMd, (unsigned) 10, &twoMd ); + mp_add_d( &twoMd, (unsigned) (c - '0'), &twoMd ); + --i; + if ( i == 0 ) break; + } + } + for ( i = 0; i <= 8; ++i ) { + if ( (M5+exponent) & ( 1 << i ) ) { + mp_mul( &twoMd, pow5+i, &twoMd ); + } + } + mp_mul_2d( &twoMd, M2+exponent+1, &twoMd ); + mp_sub( &twoMd, &twoMv, &twoMd ); + + /* + * The result, 2Mv-2Md, needs to be divided by 2M to yield a correction + * term. Because 2M may well overflow a double, we need to scale the + * denominator by a factor of 2**binExponent-mantBits + */ + + scale = binExponent - mantBits - 1; + + mp_set( &twoMv, 1 ); + for ( i = 0; i <= 8; ++i ) { + if ( M5 & ( 1 << i ) ) { + mp_mul( &twoMv, pow5+i, &twoMv ); + } + } + multiplier = M2 + scale + 1; + if ( multiplier > 0 ) { + mp_mul_2d( &twoMv, multiplier, &twoMv ); + } else if ( multiplier < 0 ) { + mp_div_2d( &twoMv, -multiplier, &twoMv, NULL ); + } + + /* + * If the result is less than unity, the error is less than 1/2 unit + * in the last place, so there's no correction to make. + */ + + if ( mp_cmp_mag( &twoMd, &twoMv ) == MP_LT ) { + return approxResult; + } + + /* + * Convert the numerator and denominator of the corrector term + * accurately to floating point numbers. + */ + + num = BignumToDouble( &twoMd ); + den = BignumToDouble( &twoMv ); + + /* + * MSVC's ldexp underflows suddenly; avoid sudden underflow by + * doing ldexp in two steps. + */ + + if ( scale < DBL_MIN_EXP * log2FLT_RADIX ) { + quot = ldexp( 1., DBL_MIN_EXP * log2FLT_RADIX + mantBits ) + * ldexp( num/den, scale - DBL_MIN_EXP * log2FLT_RADIX - mantBits ); + } else { + quot = ldexp( num/den, scale ); + } + + minincr = ldexp( 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; +} + +/* + *---------------------------------------------------------------------- + * + * BignumToDouble -- + * + * 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. + * + *---------------------------------------------------------------------- + */ + +static double +BignumToDouble( 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 ); + 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 ); + + /* + * Test for overflow, and scale the result to the correct number + * of bits. + */ + + if ( bits / log2FLT_RADIX > DBL_MAX_EXP ) { + errno = ERANGE; + r = HUGE_VAL; + } else { + r = ldexp( r, bits - mantBits ); + } + + /* Return the result with the appropriate sign. */ + + if ( a->sign == MP_ZPOS ) { + return r; + } else { + return -r; + } +} + +/* + *---------------------------------------------------------------------- + * + * ParseNaN -- + * + * Parses a "not a number" from an input string, and returns the + * double precision NaN corresponding to it. + * + * Side effects: + * Advances endPtr to follow any (hex) in the input string. + * + * If the NaN is followed by a left paren, a string of spaes + * and hexadecimal digits, and a right paren, endPtr is advanced + * to follow it. + * + * The string of hexadecimal digits is OR'ed into the resulting + * NaN, and the signum is set as well. Note that a signalling NaN + * is never returned. + * + *---------------------------------------------------------------------- + */ + +double +ParseNaN( int signum, /* Flag == 1 if minus sign has been + * seen in front of NaN */ + CONST char** endPtr ) + /* Pointer-to-pointer to char following "NaN" + * in the input string */ +{ + CONST char* p = *endPtr; + char c; + union { + Tcl_WideUInt iv; + double dv; + } theNaN; + + /* Scan off a hex number in parentheses. Embedded blanks are ok. */ + + theNaN.iv = 0; + if ( *p == '(' ) { + ++p; + for ( ; ; ) { + c = *p++; + if ( isspace(c) ) { + continue; + } else if ( c == ')' ) { + *endPtr = p; + break; + } else if ( isdigit(c) ) { + c -= '0'; + } else if ( c >= 'A' && c <= 'F' ) { + c = c - 'A' + 10; + } else if ( c >= 'a' && c <= 'f' ) { + c = c - 'a' + 10; + } else { + theNaN.iv = ( ((Tcl_WideUInt) 0x7ff8) << 48 ) + | ( ((Tcl_WideUInt) signum) << 63 ); + return theNaN.dv; + } + theNaN.iv = (theNaN.iv << 4) | c; + } + } + + /* + * Mask the hex number down to the least significant 52 bits. + * + * If the result is zero, make it 1 so that we don't return Inf + * instead of NaN + */ + + theNaN.iv &= ( ((Tcl_WideUInt) 1) << 51 ) - 1; + if ( theNaN.iv == 0 ) { + theNaN.iv = 1; + } + if ( signum ) { + theNaN.iv |= ((Tcl_WideUInt) 0xfff8) << 48; + } else { + theNaN.iv |= ((Tcl_WideUInt) 0x7ff8) << 48; + } + + *endPtr = p; + return theNaN.dv; +} diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 59cfaad..19c77f4 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclStubInit.c,v 1.109.2.4 2005/01/20 19:13:51 kennykb Exp $ + * RCS: @(#) $Id: tclStubInit.c,v 1.109.2.5 2005/02/02 15:53:27 kennykb Exp $ */ #include "tclInt.h" @@ -973,10 +973,13 @@ TclStubs tclStubs = { Tcl_GetEnsembleUnknownHandler, /* 549 */ Tcl_GetEnsembleFlags, /* 550 */ Tcl_GetEnsembleNamespace, /* 551 */ - Tcl_NewBignumObj, /* 552 */ - Tcl_DbNewBignumObj, /* 553 */ - Tcl_SetBignumObj, /* 554 */ - Tcl_GetBignumFromObj, /* 555 */ + Tcl_SetTimeProc, /* 552 */ + Tcl_QueryTimeProc, /* 553 */ + Tcl_ChannelThreadActionProc, /* 554 */ + Tcl_NewBignumObj, /* 555 */ + Tcl_DbNewBignumObj, /* 556 */ + Tcl_SetBignumObj, /* 557 */ + Tcl_GetBignumFromObj, /* 558 */ }; /* !END!: Do not edit above this line. */ diff --git a/generic/tclTest.c b/generic/tclTest.c index 5dbefb3..5239595 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -14,7 +14,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclTest.c,v 1.86.2.1 2004/12/29 22:47:03 kennykb Exp $ + * RCS: @(#) $Id: tclTest.c,v 1.86.2.2 2005/02/02 15:53:29 kennykb Exp $ */ #define TCL_TEST @@ -2277,9 +2277,14 @@ TestexprlongCmd(clientData, interp, argc, argv) 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, "4+1", &exprResult); + result = Tcl_ExprLong(interp, argv[1], &exprResult); if (result != TCL_OK) { return result; } diff --git a/generic/tclThread.c b/generic/tclThread.c index 7cc8b68..5b1fba6 100644 --- a/generic/tclThread.c +++ b/generic/tclThread.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclThread.c,v 1.8 2004/06/24 01:29:02 mistachkin Exp $ + * RCS: @(#) $Id: tclThread.c,v 1.8.2.1 2005/02/02 15:53:29 kennykb Exp $ */ #include "tclInt.h" @@ -309,7 +309,7 @@ TclRememberMutex(mutexPtr) /* *---------------------------------------------------------------------- * - * Tcl_MutexFinalize + * Tcl_MutexFinalize -- * * Finalize a single mutex and remove it from the * list of remembered objects. @@ -382,7 +382,7 @@ TclRememberCondition(condPtr) /* *---------------------------------------------------------------------- * - * Tcl_ConditionFinalize + * Tcl_ConditionFinalize -- * * Finalize a single condition variable and remove it from the * list of remembered objects. diff --git a/library/auto.tcl b/library/auto.tcl index 6638cc1..453ff59 100644 --- a/library/auto.tcl +++ b/library/auto.tcl @@ -3,7 +3,7 @@ # 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.1 2005/02/02 15:53:30 kennykb Exp $ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1998 Sun Microsystems, Inc. @@ -16,23 +16,27 @@ # # 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 -- diff --git a/libtommath/bn_fast_s_mp_sqr.c b/libtommath/bn_fast_s_mp_sqr.c new file mode 100644 index 0000000..f1df727 --- /dev/null +++ b/libtommath/bn_fast_s_mp_sqr.c @@ -0,0 +1,129 @@ +#include <tommath.h> +#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 + */ + +/* fast squaring + * + * This is the comba method where the columns of the product + * are computed first then the carries are computed. This + * has the effect of making a very simple inner loop that + * is executed the most + * + * W2 represents the outer products and W the inner. + * + * A further optimizations is made because the inner + * products are of the form "A * B * 2". The *2 part does + * not need to be computed until the end which is good + * because 64-bit shifts are slow! + * + * Based on Algorithm 14.16 on pp.597 of HAC. + * + */ +/* 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. + +Remove W2 and don't memset W + +*/ + +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 its + 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; + + /* 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 diff --git a/tests/expr-old.test b/tests/expr-old.test index c531f3b..80cd0e8 100644 --- a/tests/expr-old.test +++ b/tests/expr-old.test @@ -13,7 +13,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: expr-old.test,v 1.22 2004/11/03 22:12:51 dgp Exp $ +# RCS: @(#) $Id: expr-old.test,v 1.22.2.1 2005/02/02 15:53:30 kennykb Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2.1 @@ -961,8 +961,12 @@ testConstraint testexprlong [llength [info commands testexprlong]] testConstraint testexprstring [llength [info commands testexprstring]] 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-38.1 {Verify Tcl_ExprString's basic operation} testexprstring { list [testexprstring "1+4"] [testexprstring "2*3+4.2"] \ diff --git a/tests/io.test b/tests/io.test index 6545815..72f5042 100644 --- a/tests/io.test +++ b/tests/io.test @@ -12,7 +12,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: io.test,v 1.65 2004/11/18 19:22:12 dgp Exp $ +# RCS: @(#) $Id: io.test,v 1.65.2.1 2005/02/02 15:53:31 kennykb Exp $ if {[catch {package require tcltest 2}]} { puts stderr "Skipping tests in [info script]. tcltest 2 required." @@ -1704,6 +1704,12 @@ test io-14.9 {reuse of stdio special channels} {stdio openpipe fileevent} { 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 diff --git a/unix/configure b/unix/configure index e354426..c346072 100755 --- a/unix/configure +++ b/unix/configure @@ -7269,7 +7269,7 @@ rm -f conftest* ;; esac ;; - Rhapsody-*|Darwin-*) + Darwin-*) 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" @@ -7279,7 +7279,7 @@ rm -f conftest* DL_OBJS="tclLoadDyld.o" PLAT_OBJS=\$\(MAC\_OSX_OBJS\) DL_LIBS="" - LDFLAGS="$LDFLAGS -prebind" + LDFLAGS="$LDFLAGS -prebind -Wl,-search_paths_first" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" CFLAGS_OPTIMIZE="-Os" @@ -7514,8 +7514,16 @@ _ACEOF 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" + SHLIB_LD_FLAGS="" + fi else do64bit_ok=yes if test "$do64bitVIS" = "yes" ; then @@ -7527,8 +7535,8 @@ echo "$as_me: WARNING: \"64bit mode not supported with GCC on $system\"" >&2;} fi 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 only supported sparcv9 system" >&5 +echo "$as_me: WARNING: 64bit mode only supported sparcv9 system" >&2;} fi fi @@ -7543,6 +7551,15 @@ echo "$as_me: WARNING: \"64bit mode only supported sparcv9 system\"" >&2;} 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}' @@ -7620,8 +7637,8 @@ echo "${ECHO_T}$found" >&6 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 @@ -7877,7 +7894,7 @@ fi; ;; NetBSD-*|FreeBSD-*) ;; - Rhapsody-*|Darwin-*) + Darwin-*) ;; RISCos-*) ;; @@ -13461,7 +13478,10 @@ echo "${ECHO_T}standard shared library" >&6 # 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). + +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 @@ -13524,7 +13544,10 @@ fi #-------------------------------------------------------------------- # 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}" +eval "TCL_STUB_LIB_FILE=\"${TCL_STUB_LIB_FILE}\"" if test "${TCL_LIB_VERSIONS_OK}" = "ok"; then TCL_STUB_LIB_FLAG="-ltclstub${TCL_VERSION}" diff --git a/unix/configure.in b/unix/configure.in index b934ac2..d4749fd 100644 --- a/unix/configure.in +++ b/unix/configure.in @@ -3,7 +3,7 @@ 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.2.3 2005/01/20 19:14:39 kennykb Exp $ +# RCS: @(#) $Id: configure.in,v 1.123.2.4 2005/02/02 15:53:59 kennykb Exp $ AC_INIT([tcl],[8.5]) AC_PREREQ(2.57) @@ -439,7 +439,10 @@ 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). + +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 @@ -498,7 +501,10 @@ fi #-------------------------------------------------------------------- # 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}" +eval "TCL_STUB_LIB_FILE=\"${TCL_STUB_LIB_FILE}\"" if test "${TCL_LIB_VERSIONS_OK}" = "ok"; then TCL_STUB_LIB_FLAG="-ltclstub${TCL_VERSION}" diff --git a/unix/tcl.m4 b/unix/tcl.m4 index 73488a6..b7ad5d9 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -1389,7 +1389,7 @@ dnl AC_CHECK_TOOL(AR, ar) ;; esac ;; - Rhapsody-*|Darwin-*) + Darwin-*) 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" @@ -1399,7 +1399,7 @@ dnl AC_CHECK_TOOL(AR, ar) DL_OBJS="tclLoadDyld.o" PLAT_OBJS=\$\(MAC\_OSX_OBJS\) DL_LIBS="" - LDFLAGS="$LDFLAGS -prebind" + LDFLAGS="$LDFLAGS -prebind -Wl,-search_paths_first" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" CFLAGS_OPTIMIZE="-Os" @@ -1596,13 +1596,21 @@ dnl AC_CHECK_TOOL(AR, ar) [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" + SHLIB_LD_FLAGS="" + fi else do64bit_ok=yes if test "$do64bitVIS" = "yes" ; then @@ -1614,7 +1622,7 @@ dnl AC_CHECK_TOOL(AR, ar) fi fi else - AC_MSG_WARN("64bit mode only supported sparcv9 system") + AC_MSG_WARN([64bit mode only supported sparcv9 system]) fi fi @@ -1629,6 +1637,15 @@ dnl AC_CHECK_TOOL(AR, ar) 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}' @@ -1670,7 +1687,7 @@ dnl AC_CHECK_TOOL(AR, ar) 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 @@ -1797,7 +1814,7 @@ dnl AC_CHECK_TOOL(AR, ar) ;; NetBSD-*|FreeBSD-*) ;; - Rhapsody-*|Darwin-*) + Darwin-*) ;; RISCos-*) ;; diff --git a/unix/tclUnixChan.c b/unix/tclUnixChan.c index 5b9fa0a..170be72 100644 --- a/unix/tclUnixChan.c +++ b/unix/tclUnixChan.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclUnixChan.c,v 1.53 2004/11/17 02:51:32 hobbs Exp $ + * RCS: @(#) $Id: tclUnixChan.c,v 1.53.2.1 2005/02/02 15:54:01 kennykb Exp $ */ #include "tclInt.h" /* Internal definitions for Tcl. */ @@ -232,6 +232,10 @@ static int FileOutputProc _ANSI_ARGS_(( 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 Tcl_WideInt FileWideSeekProc _ANSI_ARGS_((ClientData instanceData, Tcl_WideInt offset, int mode, int *errorCode)); static void FileWatchProc _ANSI_ARGS_((ClientData instanceData, @@ -291,7 +295,7 @@ static Tcl_Channel MakeTcpClientChannelMode _ANSI_ARGS_( 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. */ @@ -305,6 +309,11 @@ static Tcl_ChannelType fileChannelType = { NULL, /* flush proc. */ NULL, /* handler proc. */ FileWideSeekProc, /* wide seek proc. */ +#ifdef DEPRECATED + FileThreadActionProc, /* thread actions */ +#else + NULL, +#endif }; #ifdef SUPPORTS_TTY @@ -315,7 +324,7 @@ static Tcl_ChannelType fileChannelType = { 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 @@ -332,6 +341,8 @@ static Tcl_ChannelType ttyChannelType = { FileBlockModeProc, /* Set blocking or non-blocking mode.*/ NULL, /* flush proc. */ NULL, /* handler proc. */ + NULL, /* wide seek proc. */ + NULL, /* thread action proc. */ }; #endif /* SUPPORTS_TTY */ @@ -342,7 +353,7 @@ static Tcl_ChannelType ttyChannelType = { 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. */ @@ -355,6 +366,8 @@ static Tcl_ChannelType tcpChannelType = { TcpBlockModeProc, /* Set blocking or non-blocking mode.*/ NULL, /* flush proc. */ NULL, /* handler proc. */ + NULL, /* wide seek proc. */ + NULL, /* thread action proc. */ }; @@ -1821,6 +1834,15 @@ TclpOpenFileChannel(interp, pathPtr, mode, permissions) 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; @@ -3239,13 +3261,13 @@ TclUnixWaitForFile(fd, mask, timeout) 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. @@ -3256,35 +3278,39 @@ TclUnixWaitForFile(fd, mask, timeout) *---------------------------------------------------------------------- */ -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; { -} - -/* - *---------------------------------------------------------------------- - * - * TclpSpliceFileChannel -- - * - * Insert thread local ref for this channel. - * Tcl_SpliceChannel for more info. - * - * Results: - * None. - * - * Side effects: - * None. This is a no-op under unix. - * - *---------------------------------------------------------------------- - */ + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + FileState *fsPtr = (FileState *) instanceData; -void -TclpSpliceFileChannel(chan) - Tcl_Channel chan; /* The channel being removed. Must - * not be referenced in any - * interpreter. */ -{ + 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 diff --git a/unix/tclUnixEvent.c b/unix/tclUnixEvent.c index 98ab452..9f8d1ad 100644 --- a/unix/tclUnixEvent.c +++ b/unix/tclUnixEvent.c @@ -8,10 +8,10 @@ * 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.1 2005/02/02 15:54:01 kennykb Exp $ */ -#include "tclPort.h" +#include "tclInt.h" /* *---------------------------------------------------------------------- @@ -34,7 +34,7 @@ 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 @@ -52,13 +52,23 @@ Tcl_Sleep(ms) 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. diff --git a/unix/tclUnixNotfy.c b/unix/tclUnixNotfy.c index c1c4f9b..0c76d2a 100644 --- a/unix/tclUnixNotfy.c +++ b/unix/tclUnixNotfy.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclUnixNotfy.c,v 1.18.2.1 2004/12/08 18:24:37 kennykb Exp $ + * RCS: @(#) $Id: tclUnixNotfy.c,v 1.18.2.2 2005/02/02 15:54:01 kennykb Exp $ */ #include "tclInt.h" @@ -652,11 +652,17 @@ Tcl_WaitForEvent(timePtr) { 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 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -672,9 +678,23 @@ Tcl_WaitForEvent(timePtr) */ if (timePtr) { - timeout.tv_sec = timePtr->sec; - timeout.tv_usec = timePtr->usec; - timeoutPtr = &timeout; + /* 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; + + (*tclScaleTimeProcPtr) (&myTime, tclTimeClientData); + +#ifdef TCL_THREADS + myTimePtr = &myTime; +#else + timeout.tv_sec = myTime.sec; + timeout.tv_usec = myTime.usec; + timeoutPtr = &timeout; +#endif + #ifndef TCL_THREADS } else if (tsdPtr->numFdBits == 0) { /* @@ -688,7 +708,11 @@ Tcl_WaitForEvent(timePtr) return -1; #endif } else { +#ifdef TCL_THREADS + myTimePtr = NULL; +#else timeoutPtr = NULL; +#endif } #ifdef TCL_THREADS @@ -700,7 +724,7 @@ Tcl_WaitForEvent(timePtr) 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 @@ -711,7 +735,7 @@ Tcl_WaitForEvent(timePtr) waitForFiles = 1; tsdPtr->pollState = POLL_WANT; - timePtr = NULL; + myTimePtr = NULL; } else { tsdPtr->pollState = 0; } @@ -740,7 +764,7 @@ Tcl_WaitForEvent(timePtr) FD_ZERO( &(tsdPtr->readyMasks.exceptional) ); if (!tsdPtr->eventReady) { - Tcl_ConditionWait(&tsdPtr->waitCV, ¬ifierMutex, timePtr); + Tcl_ConditionWait(&tsdPtr->waitCV, ¬ifierMutex, myTimePtr); } tsdPtr->eventReady = 0; diff --git a/unix/tclUnixPipe.c b/unix/tclUnixPipe.c index ee8bacc..82dc779 100644 --- a/unix/tclUnixPipe.c +++ b/unix/tclUnixPipe.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclUnixPipe.c,v 1.26 2004/10/06 16:08:57 dgp Exp $ + * RCS: @(#) $Id: tclUnixPipe.c,v 1.26.2.1 2005/02/02 15:54:01 kennykb Exp $ */ #include "tclInt.h" @@ -71,7 +71,7 @@ static int SetupStdFile _ANSI_ARGS_((TclFile file, int type)); 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. */ @@ -84,6 +84,8 @@ static Tcl_ChannelType pipeChannelType = { PipeBlockModeProc, /* Set blocking or non-blocking mode.*/ NULL, /* flush proc. */ NULL, /* handler proc. */ + NULL, /* wide seek proc */ + NULL, /* thread action proc */ }; /* diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c index 0189c11..6ac3e21 100644 --- a/unix/tclUnixSock.c +++ b/unix/tclUnixSock.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclUnixSock.c,v 1.9 2004/04/06 22:25:57 dgp Exp $ + * RCS: @(#) $Id: tclUnixSock.c,v 1.9.2.1 2005/02/02 15:54:02 kennykb Exp $ */ #include "tclInt.h" @@ -147,49 +147,3 @@ TclpHasSockets(interp) { 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; -{ -} diff --git a/unix/tclUnixTime.c b/unix/tclUnixTime.c index 32cea2d..3740817 100644 --- a/unix/tclUnixTime.c +++ b/unix/tclUnixTime.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclUnixTime.c,v 1.22 2004/09/27 14:31:20 kennykb Exp $ + * RCS: @(#) $Id: tclUnixTime.c,v 1.22.2.1 2005/02/02 15:54:02 kennykb Exp $ */ #include "tclInt.h" @@ -45,6 +45,17 @@ static char* lastTZ = NULL; /* Holds the last setting of the 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; /* *----------------------------------------------------------------------------- @@ -92,18 +103,22 @@ 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; @@ -235,6 +250,9 @@ TclpGetTimeZone (currentTime) * 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. * @@ -248,12 +266,7 @@ 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); } /* @@ -384,7 +397,126 @@ TclpLocaltime_unix( 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; +{ + /* 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; +} /* *---------------------------------------------------------------------- * diff --git a/win/Makefile.in b/win/Makefile.in index cd40340..a312e9e 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -5,7 +5,7 @@ # "autoconf" program (constructs like "@foo@" will get replaced in the # actual Makefile. # -# RCS: @(#) $Id: Makefile.in,v 1.84.2.4 2005/01/20 19:14:43 kennykb Exp $ +# RCS: @(#) $Id: Makefile.in,v 1.84.2.5 2005/02/02 15:54:02 kennykb Exp $ VERSION = @TCL_VERSION@ @@ -267,6 +267,7 @@ GENERIC_OBJS = \ tclResult.$(OBJEXT) \ tclScan.$(OBJEXT) \ tclStringObj.$(OBJEXT) \ + tclStrToD.$(OBJEXT) \ tclStubInit.$(OBJEXT) \ tclStubLib.$(OBJEXT) \ tclThread.$(OBJEXT) \ @@ -284,6 +285,7 @@ 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_clamp.${OBJEXT} \ @@ -305,6 +307,7 @@ TOMMATH_OBJS = \ bn_mp_init_multi.${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} \ @@ -316,13 +319,17 @@ TOMMATH_OBJS = \ bn_mp_radix_smap.${OBJEXT} \ bn_mp_read_radix.${OBJEXT} \ bn_mp_rshd.${OBJEXT} \ + bn_mp_set.${OBJEXT} \ + bn_mp_sqr.${OBJEXT} \ bn_mp_sub.${OBJEXT} \ bn_mp_sub_d.${OBJEXT} \ bn_mp_toom_mul.${OBJEXT} \ + bn_mp_toom_sqr.${OBJEXT} \ bn_mp_toradix_n.${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} diff --git a/win/makefile.vc b/win/makefile.vc index ad5b4cc..7c0ac10 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -12,7 +12,7 @@ # Copyright (c) 2001-2004 David Gravereaux. # #------------------------------------------------------------------------------ -# RCS: @(#) $Id: makefile.vc,v 1.135 2004/10/27 20:53:38 davygrvy Exp $ +# RCS: @(#) $Id: makefile.vc,v 1.135.2.1 2005/02/02 15:54:02 kennykb Exp $ #------------------------------------------------------------------------------ !if !defined(MSDEVDIR) && !defined(MSVCDIR) @@ -303,6 +303,7 @@ TCLOBJS = \ $(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 \ @@ -310,6 +311,7 @@ TCLOBJS = \ $(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 \ @@ -328,6 +330,55 @@ TCLOBJS = \ $(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_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_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_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_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_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_sqr.obj \ + $(TMP_DIR)\bn_mp_sub.obj \ + $(TMP_DIR)\bn_mp_sub_d.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_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 @@ -338,6 +389,7 @@ TCLSTUBOBJS = $(TMP_DIR)\tclStubLib.obj COMPATDIR = $(ROOT)\compat DOCDIR = $(ROOT)\doc GENERICDIR = $(ROOT)\generic +TOMMATHDIR = $(ROOT)\libtommath TOOLSDIR = $(ROOT)\tools WINDIR = $(ROOT)\win @@ -392,9 +444,9 @@ 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 CON_CFLAGS = $(cflags) $(cdebug) $(crt) -DCONSOLE TCL_CFLAGS = $(BASE_CFLAGS) $(OPTDEFINES) STUB_CFLAGS = $(cflags) $(cdebug) $(OPTDEFINES) @@ -836,6 +888,11 @@ $(GENERICDIR)\regguts.h: $(GENERICDIR)\regcustom.h $< << +{$(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)\ @<< $< diff --git a/win/tclWinChan.c b/win/tclWinChan.c index 2eb2bb3..9f9ea94 100644 --- a/win/tclWinChan.c +++ b/win/tclWinChan.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclWinChan.c,v 1.37.2.1 2005/01/20 14:53:42 kennykb Exp $ + * RCS: @(#) $Id: tclWinChan.c,v 1.37.2.2 2005/02/02 15:54:03 kennykb Exp $ */ #include "tclWinInt.h" @@ -97,7 +97,9 @@ static Tcl_WideInt FileWideSeekProc _ANSI_ARGS_((ClientData instanceData, static void FileSetupProc _ANSI_ARGS_((ClientData clientData, int flags)); static void FileWatchProc _ANSI_ARGS_((ClientData instanceData, - int mask)); + int mask)); +static void FileThreadActionProc _ANSI_ARGS_ (( + ClientData instanceData, int action)); /* * This structure describes the channel type structure for file based IO. @@ -105,7 +107,7 @@ static void FileWatchProc _ANSI_ARGS_((ClientData instanceData, 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. */ @@ -119,6 +121,7 @@ static Tcl_ChannelType fileChannelType = { NULL, /* flush proc. */ NULL, /* handler proc. */ FileWideSeekProc, /* Wide seek proc. */ + FileThreadActionProc, /* Thread action proc. */ }; #if defined(HAVE_NO_SEH) && defined(TCL_MEM_DEBUG) @@ -430,11 +433,11 @@ FileCloseProc(instanceData, interp) if (infoPtr == fileInfoPtr) { /* * This channel exists on the thread local list. It should - * have been removed by an earlier call to TclpCutFileChannel, + * 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. */ - TclpCutFileChannel(fileInfoPtr->channel); + FileThreadActionProc(fileInfoPtr,TCL_CHANNEL_THREAD_REMOVE); break; } } @@ -1307,8 +1310,11 @@ TclWinOpenFileChannel(handle, channelName, permissions, appendMode) } 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; @@ -1373,10 +1379,9 @@ TclWinFlushDirtyChannels () /* *---------------------------------------------------------------------- * - * 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. @@ -1387,77 +1392,38 @@ TclWinFlushDirtyChannels () *---------------------------------------------------------------------- */ -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); - Channel *chanPtr = (Channel *) chan; - FileInfo *infoPtr; - FileInfo **nextPtrPtr; - int removed = 0; - - if (chanPtr->typePtr != &fileChannelType) { - return; - } - - infoPtr = (FileInfo *) chanPtr->instanceData; + FileInfo *infoPtr = (FileInfo *) instanceData; - for (nextPtrPtr = &(tsdPtr->firstFilePtr); (*nextPtrPtr) != NULL; - nextPtrPtr = &((*nextPtrPtr)->nextPtr)) { - if ((*nextPtrPtr) == infoPtr) { - (*nextPtrPtr) = infoPtr->nextPtr; - removed = 1; - break; + 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"); - } -} - -/* - *---------------------------------------------------------------------- - * - * 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; + /* + * 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 (chanPtr->typePtr != &fileChannelType) { - return; + if (!removed) { + Tcl_Panic("file info ptr not on thread channel list"); + } } - - infoPtr = (FileInfo *) chanPtr->instanceData; - - infoPtr->nextPtr = tsdPtr->firstFilePtr; - tsdPtr->firstFilePtr = infoPtr; } diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index e2dedc4..1ae54dc 100644 --- a/win/tclWinConsole.c +++ b/win/tclWinConsole.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclWinConsole.c,v 1.12 2004/09/10 01:52:17 davygrvy Exp $ + * RCS: @(#) $Id: tclWinConsole.c,v 1.12.2.1 2005/02/02 15:54:04 kennykb Exp $ */ #include "tclWinInt.h" @@ -148,7 +148,7 @@ 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, @@ -160,6 +160,9 @@ static DWORD WINAPI ConsoleWriterThread(LPVOID arg); static void ProcExitHandler(ClientData clientData); static int WaitForRead(ConsoleInfo *infoPtr, int blocking); +static void ConsoleThreadActionProc _ANSI_ARGS_ (( + ClientData instanceData, int action)); + /* * This structure describes the channel type structure for command console * based IO. @@ -167,7 +170,7 @@ static int WaitForRead(ConsoleInfo *infoPtr, int blocking); 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. */ @@ -180,6 +183,8 @@ static Tcl_ChannelType consoleChannelType = { ConsoleBlockModeProc, /* Set blocking or non-blocking mode.*/ NULL, /* flush proc. */ NULL, /* handler proc. */ + NULL, /* wide seek proc */ + ConsoleThreadActionProc, /* thread action proc */ }; /* @@ -198,7 +203,7 @@ static Tcl_ChannelType consoleChannelType = { *---------------------------------------------------------------------- */ -static ThreadSpecificData * +static void ConsoleInit() { ThreadSpecificData *tsdPtr; @@ -224,7 +229,6 @@ ConsoleInit() Tcl_CreateEventSource(ConsoleSetupProc, ConsoleCheckProc, NULL); Tcl_CreateThreadExitHandler(ConsoleExitHandler, NULL); } - return tsdPtr; } /* @@ -1169,7 +1173,10 @@ ConsoleReaderThread(LPVOID arg) */ 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); } @@ -1255,7 +1262,10 @@ ConsoleWriterThread(LPVOID arg) */ 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); } @@ -1290,10 +1300,9 @@ TclWinOpenConsoleChannel(handle, channelName, 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. @@ -1304,9 +1313,12 @@ TclWinOpenConsoleChannel(handle, channelName, permissions) 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 @@ -1318,8 +1330,6 @@ TclWinOpenConsoleChannel(handle, channelName, permissions) infoPtr->channel = Tcl_CreateChannel(&consoleChannelType, channelName, (ClientData) infoPtr, permissions); - infoPtr->threadId = Tcl_GetCurrentThread(); - if (permissions & TCL_READABLE) { /* * Make sure the console input buffer is ready for only character @@ -1360,3 +1370,51 @@ TclWinOpenConsoleChannel(handle, channelName, permissions) 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); +} diff --git a/win/tclWinNotify.c b/win/tclWinNotify.c index 3bcfd2b..3979e4a 100644 --- a/win/tclWinNotify.c +++ b/win/tclWinNotify.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclWinNotify.c,v 1.16 2004/04/06 22:25:58 dgp Exp $ + * RCS: @(#) $Id: tclWinNotify.c,v 1.16.2.1 2005/02/02 15:54:04 kennykb Exp $ */ #include "tclInt.h" @@ -444,7 +444,17 @@ Tcl_WaitForEvent( */ 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; + + (*tclScaleTimeProcPtr) (&myTime, tclTimeClientData); + + timeout = myTime.sec * 1000 + myTime.usec / 1000; } else { timeout = INFINITE; } @@ -544,15 +554,24 @@ Tcl_Sleep(ms) Tcl_Time now; /* Current wall clock time */ Tcl_Time desired; /* Desired wakeup time */ - DWORD sleepTime = ms; /* Time to sleep */ + 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 + ( ms / 1000 ); - desired.usec = now.usec + 1000 * ( ms % 1000 ); + desired.sec = now.sec + vdelay.sec; + desired.usec = now.usec + vdelay.usec; if ( desired.usec > 1000000 ) { ++desired.sec; desired.usec -= 1000000; } + + /* TIP #233: Scale delay from virtual to real-time */ + + (*tclScaleTimeProcPtr) (&vdelay, tclTimeClientData); + sleepTime = vdelay.sec * 1000 + vdelay.usec / 1000; for ( ; ; ) { Sleep( sleepTime ); @@ -563,8 +582,12 @@ Tcl_Sleep(ms) && ( now.usec >= desired.usec ) ) { break; } - sleepTime = ( ( 1000 * ( desired.sec - now.sec ) ) - + ( ( desired.usec - now.usec ) / 1000 ) ); + + vdelay.sec = desired.sec - now.sec; + vdelay.usec = desired.usec - now.usec; + + (*tclScaleTimeProcPtr) (&vdelay, tclTimeClientData); + sleepTime = vdelay.sec * 1000 + vdelay.usec / 1000; } } diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c index 2601e4f..98b972b 100644 --- a/win/tclWinPipe.c +++ b/win/tclWinPipe.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclWinPipe.c,v 1.53 2004/12/01 23:18:55 dgp Exp $ + * RCS: @(#) $Id: tclWinPipe.c,v 1.53.2.1 2005/02/02 15:54:04 kennykb Exp $ */ #include "tclWinInt.h" @@ -205,6 +205,9 @@ static void ProcExitHandler(ClientData clientData); static int TempFileName(WCHAR name[MAX_PATH]); static int WaitForRead(PipeInfo *infoPtr, int blocking); +static void PipeThreadActionProc _ANSI_ARGS_ (( + ClientData instanceData, int action)); + /* * This structure describes the channel type structure for command pipe * based IO. @@ -212,7 +215,7 @@ static int WaitForRead(PipeInfo *infoPtr, int blocking); 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. */ @@ -225,6 +228,8 @@ static Tcl_ChannelType pipeChannelType = { PipeBlockModeProc, /* Set blocking or non-blocking mode.*/ NULL, /* flush proc. */ NULL, /* handler proc. */ + NULL, /* wide seek proc */ + PipeThreadActionProc, /* thread action proc */ }; /* @@ -1696,6 +1701,7 @@ TclpCreateCommandChannel( 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 @@ -2977,7 +2983,10 @@ PipeReaderThread(LPVOID arg) */ 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); } @@ -3065,10 +3074,60 @@ PipeWriterThread(LPVOID arg) */ 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); +} diff --git a/win/tclWinSerial.c b/win/tclWinSerial.c index 2fa32a1..41e80d0 100644 --- a/win/tclWinSerial.c +++ b/win/tclWinSerial.c @@ -11,7 +11,7 @@ * * 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.1 2005/02/02 15:54:05 kennykb Exp $ */ #include "tclWinInt.h" @@ -200,6 +200,9 @@ static int SerialSetOptionProc _ANSI_ARGS_(( CONST char *value)); static DWORD WINAPI SerialWriterThread(LPVOID arg); +static void SerialThreadActionProc _ANSI_ARGS_ (( + ClientData instanceData, int action)); + /* * This structure describes the channel type structure for command serial * based IO. @@ -207,7 +210,7 @@ static DWORD WINAPI SerialWriterThread(LPVOID arg); 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. */ @@ -220,6 +223,8 @@ static Tcl_ChannelType serialChannelType = { SerialBlockProc, /* Set blocking or non-blocking mode.*/ NULL, /* flush proc. */ NULL, /* handler proc. */ + NULL, /* wide seek proc */ + SerialThreadActionProc, /* thread action proc */ }; /* @@ -1384,7 +1389,10 @@ SerialWriterThread(LPVOID arg) */ 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); } @@ -1458,16 +1466,25 @@ TclWinOpenSerialChannel(handle, channelName, permissions) 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->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 @@ -1479,14 +1496,6 @@ TclWinOpenSerialChannel(handle, channelName, permissions) 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, @@ -2158,3 +2167,51 @@ SerialGetOptionProc(instanceData, interp, optionName, dsPtr) "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); +} diff --git a/win/tclWinSock.c b/win/tclWinSock.c index c732d36..91f7097 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclWinSock.c,v 1.44 2004/10/06 14:39:20 dkf Exp $ + * RCS: @(#) $Id: tclWinSock.c,v 1.44.2.1 2005/02/02 15:54:05 kennykb Exp $ */ #include "tclWinInt.h" @@ -265,6 +265,10 @@ static int WaitForSocketEvent _ANSI_ARGS_(( int *errorCodePtr)); static DWORD WINAPI SocketThread _ANSI_ARGS_((LPVOID arg)); +static void TcpThreadActionProc _ANSI_ARGS_ (( + ClientData instanceData, int action)); + + /* * This structure describes the channel type structure for TCP socket * based IO. @@ -272,7 +276,7 @@ static DWORD WINAPI SocketThread _ANSI_ARGS_((LPVOID arg)); 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. */ @@ -285,6 +289,8 @@ static Tcl_ChannelType tcpChannelType = { TcpBlockProc, /* Set socket into (non-)blocking mode. */ NULL, /* flush proc. */ NULL, /* handler proc. */ + NULL, /* wide seek proc */ + TcpThreadActionProc, /* thread action proc */ }; @@ -970,7 +976,7 @@ TcpCloseProc(instanceData, interp) Tcl_Interp *interp; /* Unused. */ { SocketInfo *infoPtr = (SocketInfo *) instanceData; - SocketInfo **nextPtrPtr; + /* TIP #218 */ int errorCode = 0; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -995,20 +1001,12 @@ TcpCloseProc(instanceData, interp) } } - /* - * Remove the socket from socketList. + /* 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. */ - - WaitForSingleObject(tsdPtr->socketListLock, INFINITE); - for (nextPtrPtr = &(tsdPtr->socketList); (*nextPtrPtr) != NULL; - nextPtrPtr = &((*nextPtrPtr)->nextPtr)) { - if ((*nextPtrPtr) == infoPtr) { - (*nextPtrPtr) = infoPtr->nextPtr; - break; - } - } - - SetEvent(tsdPtr->socketListLock); ckfree((char *) infoPtr); return errorCode; } @@ -1025,7 +1023,7 @@ TcpCloseProc(instanceData, interp) * Returns a newly allocated SocketInfo. * * Side effects: - * Adds the socket to the global socket list. + * None, except for allocation of memory. * *---------------------------------------------------------------------- */ @@ -1049,11 +1047,12 @@ NewSocketInfo(socket) 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; } @@ -1069,7 +1068,7 @@ NewSocketInfo(socket) * 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. * *---------------------------------------------------------------------- */ @@ -2665,16 +2664,13 @@ TclWinGetServByName(const char * name, const char * proto) 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. @@ -2685,116 +2681,68 @@ TclWinGetServByName(const char * name, const char * proto) *---------------------------------------------------------------------- */ -void -TclpCutSockChannel(chan) - Tcl_Channel chan; /* The channel being removed. Must - * not be referenced in any - * interpreter. */ +static void +TcpThreadActionProc (instanceData, action) + ClientData instanceData; + int action; { 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. - */ + SocketInfo *infoPtr = (SocketInfo *) instanceData; + int notifyCmd; - tsdPtr = TCL_TSD_INIT(&dataKey); - infoPtr = (SocketInfo *) Tcl_GetChannelInstanceData (chan); + if (action == TCL_CHANNEL_THREAD_INSERT) { + /* + * Ensure that socket subsystem is initialized in this thread, or + * else sockets will not work. + */ - for (nextPtrPtr = &(tsdPtr->socketList); (*nextPtrPtr) != NULL; - nextPtrPtr = &((*nextPtrPtr)->nextPtr)) { - if ((*nextPtrPtr) == infoPtr) { - (*nextPtrPtr) = infoPtr->nextPtr; - removed = 1; - break; - } - } + Tcl_MutexLock(&socketMutex); + InitSockets(); + Tcl_MutexUnlock(&socketMutex); - /* - * 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. - */ + tsdPtr = TCL_TSD_INIT(&dataKey); - if (!removed) { - Tcl_Panic("file info ptr not on thread channel list"); - } + WaitForSingleObject(tsdPtr->socketListLock, INFINITE); + infoPtr->nextPtr = tsdPtr->socketList; + tsdPtr->socketList = infoPtr; + SetEvent(tsdPtr->socketListLock); - /* - * Stop notifications for the socket to occur in this thread. - */ + 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); - 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. - * - *---------------------------------------------------------------------- - */ + /* + * 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. + */ -void -TclpSpliceSockChannel(chan) - Tcl_Channel chan; /* The channel being removed. Must - * not be referenced in any - * interpreter. */ -{ - ThreadSpecificData *tsdPtr; - SocketInfo *infoPtr; + if (!removed) { + Tcl_Panic("file info ptr not on thread channel list"); + } - if (Tcl_GetChannelType(chan) != &tcpChannelType) { - return; + notifyCmd = UNSELECT; } /* - * 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. + * Ensure that, or stop, notifications for the socket occur in this thread. */ SendMessage(tsdPtr->hwnd, SOCKET_SELECT, - (WPARAM) SELECT, (LPARAM) infoPtr); + (WPARAM) notifyCmd, (LPARAM) infoPtr); } diff --git a/win/tclWinTime.c b/win/tclWinTime.c index 48460bb..ff8e664 100644 --- a/win/tclWinTime.c +++ b/win/tclWinTime.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclWinTime.c,v 1.28 2004/09/07 17:39:00 kennykb Exp $ + * RCS: @(#) $Id: tclWinTime.c,v 1.28.2.1 2005/02/02 15:54:07 kennykb Exp $ */ #include "tclInt.h" @@ -138,6 +138,17 @@ static Tcl_WideInt AccumulateSample _ANSI_ARGS_(( Tcl_WideInt perfCounter, Tcl_WideUInt fileTime )); + +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; /* *---------------------------------------------------------------------- @@ -160,7 +171,8 @@ unsigned long TclpGetSeconds() { Tcl_Time t; - Tcl_GetTime( &t ); + /* Tcl_GetTime inlined */ + (*tclGetTimeProcPtr) (&t, tclTimeClientData); return t.sec; } @@ -195,7 +207,9 @@ TclpGetClicks() Tcl_Time now; /* Current Tcl time */ unsigned long retval; /* Value to return */ - Tcl_GetTime( &now ); + /* Tcl_GetTime inlined */ + (*tclGetTimeProcPtr) (&now, tclTimeClientData); + retval = ( now.sec * 1000000 ) + now.usec; return retval; @@ -258,6 +272,64 @@ 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; @@ -1182,3 +1254,67 @@ TclpLocaltime( 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; + } +} + |