Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Overview
| Comment: | merge updates from HEAD |
|---|---|
| Timelines: | family | ancestors | descendants | both | dgp-refactor |
| Files: | files | file ages | folders |
| SHA1: |
eb6dfbd0e7dabe2da4aa88f84bcd4e0a |
| User & Date: | dgp 2009-12-08 18:39:18.000 |
Context
|
2009-12-08
| ||
| 19:21 | merge updates from HEAD check-in: cff185fca4 user: dgp tags: dgp-refactor | |
| 18:39 | merge updates from HEAD check-in: eb6dfbd0e7 user: dgp tags: dgp-refactor | |
|
2009-11-25
| ||
| 16:20 | merge updates from HEAD check-in: 20fd2844f9 user: dgp tags: dgp-refactor | |
Changes
Changes to ChangeLog.
1 2 3 4 5 6 7 8 9 10 | 2009-11-25 Stuart Cassoff <stwo@users.sf.net> * unix/configure.in: [Patch 2892871]: Remove unneeded * unix/tcl.m4: AC_STRUCT_TIMEZONE and use * unix/tclConfig.h.in: AC_CHECK_MEMBERS([struct stat.st_blksize]) * unix/tclUnixFCmd.c: instead of AC_STRUCT_ST_BLKSIZE. * unix/configure: Regenerated with autoconf-2.59. 2009-11-24 Andreas Kupries <andreask@activestate.com> | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | < | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 | 2009-12-08 Donal K. Fellows <dkf@users.sf.net> * generic/tclExecute.c (TclExecuteByteCode): Make the dict opcodes more sparing in their use of C variables, to reduce size of TEBC activiation record a little bit. 2009-12-07 Miguel Sofer <msofer@users.sf.net> * generic/tclExecute.c (TEBC): Grouping "slow" variables into structs, to reduce register pressure and help the compiler with variable allocation. 2009-12-07 Miguel Sofer <msofer@users.sf.net> * generic/tclExecute.c: Start cleaning the TEBC stables * generic/tclInt.h: * generic/tclCmdIL.c: [Bug 2910094]: Fix by aku * tests/coroutine.test: * generic/tclBasic.c: Arrange for [tailcall] to be created with the other builtins: was being created in a separate call, leftover from pre-tip days. 2009-12-07 Don Porter <dgp@users.sourceforge.net> * generic/tclStrToD.c: [Bug 2902010]: Correct conditional compile directives to better detect the toolchain that needs extra work for proper underflow treatment instead of merely detecting the MIPS platform. 2009-12-07 Miguel Sofer <msofer@users.sf.net> * generic/tclBasic.c: [Patch 2910056]: Add ::tcl::unsupported::yieldTo * generic/tclInt.h: 2009-12-07 Donal K. Fellows <dkf@users.sf.net> * generic/tclCmdMZ.c (TryPostBody): [Bug 2910044]: Close off memory leak in [try] when a variable-free handler clause is present. 2009-12-05 Miguel Sofer <msofer@users.sf.net> * generic/tclBasic.c: Small changes for clarity in tailcall * generic/tclExecute.c: and coroutine code. * tests/coroutine.test: * tests/tailcall.test: Remove some old unused crud; improved the stack depth tests. * generic/tclBasic.c: Fixed things so that you can tailcall * generic/tclNamesp.c: properly out of a coroutine. * tests/tailcall.test: * generic/tclInterp.c: Fixed tailcalls for same-interp aliases (no test) 2009-12-03 Donal K. Fellows <dkf@users.sf.net> * library/safe.tcl (::safe::AliasEncoding): Make the safe encoding command behave more closely like the unsafe one (for safe ops). (::safe::AliasGlob): [Bug 2906841]: Clamp down on evil use of [glob] in safe interpreters. * tests/safe.test: Rewrite to use tcltest2 better. 2009-12-02 Jan Nijtmans <nijtmans@users.sf.net> * tools/genStubs.tcl: Add support for win32 CALLBACK functions and remove obsolete "emitStubs" and "genStubs" functions. * win/Makefile.in: Use tcltest86.dll for all tests, and add .PHONY rules to preemptively stop trouble that plagued Tk from hitting Tcl too. 2009-11-30 Jan Nijtmans <nijtmans@users.sf.net> * generic/tcl.h: Don't use EXPORT for Tcl_InitStubs * win/Makefile.in: Better dependancies in case of static build. 2009-11-30 Donal K. Fellows <dkf@users.sf.net> * doc/Tcl.n: [Bug 2901433]: Improved description of expansion to mention that it is using list syntax. 2009-11-27 Kevin B. Kenny <kennykb@acm.org> * win/tclAppInit.c (Tcl_AppInit): [Bug 2902965]: Reverted Jan's change that added a call to Tcl_InitStubs. The 'tclsh' and 'tcltest' programs are providers, not consumers of the Stubs table, and should not link with the Stubs library, but only with the main Tcl library. (In any case, the presence of Tcl_InitStubs broke the build.) 2009-11-27 Donal K. Fellows <dkf@users.sf.net> * doc/BoolObj.3, doc/Class.3, doc/CrtChannel.3, doc/DictObj.3: * doc/DoubleObj.3, doc/Ensemble.3, doc/Environment.3: * doc/FileSystem.3, doc/Hash.3, doc/IntObj.3, doc/Limit.3: * doc/Method.3, doc/NRE.3, doc/ObjectType.3, doc/PkgRequire.3: * doc/SetChanErr.3, doc/SetResult.3: [Patch 2903921]: Many small spelling fixes from Larry Virden. BUMP VERSION OF TCLOO TO 0.6.2. Too many people need accumulated small versions and bugfixes, so the version-bump removes confusion. * generic/tclOOBasic.c (TclOO_Object_LinkVar): [Bug 2903811]: Remove unneeded restrictions on who can usefully call this method. 2009-11-26 Donal K. Fellows <dkf@users.sf.net> * unix/Makefile.in: Add .PHONY rules and documentation to preemptively stop trouble that plagued Tk from hitting Tcl too, and to make the overall makefile easier to understand. Some reorganization too to move related rules closer together. 2009-11-26 Jan Nijtmans <nijtmans@users.sf.net> * win/Makefile.in: [Bug 2902965]: Fix stub related changes that * win/makefile.vc: caused tclkit build to break. * win/tclAppInit.c * unix/tcl.m4 * unix/Makefile.in * unix/tclAppInit.c * unix/configure: (regenerated) 2009-11-25 Kevin B. Kenny <kennykb@acm.org> * win/Makefile.in: Added a 'test-tcl' rule that is identical to 'test' except that it does not go spelunking in 'pkgs/'. (This rule has existed in unix/Makefile.in for some time.) 2009-11-25 Stuart Cassoff <stwo@users.sf.net> * unix/configure.in: [Patch 2892871]: Remove unneeded * unix/tcl.m4: AC_STRUCT_TIMEZONE and use * unix/tclConfig.h.in: AC_CHECK_MEMBERS([struct stat.st_blksize]) * unix/tclUnixFCmd.c: instead of AC_STRUCT_ST_BLKSIZE. * unix/configure: Regenerated with autoconf-2.59. 2009-11-24 Andreas Kupries <andreask@activestate.com> * library/tclIndex: Manually redone the part of tclIndex dealing with safe.tcl and tm.tcl. This part passes the testsuite. Note that automatic regeneration of this part is not possible because it wrongly puts 'safe::Setup' on the list, and wrongly leaves out 'safe::Log' which is more dynamically created than the generator expects. Further note that the file "clock.tcl" is explicitly loaded by "init.tcl", the first time the clock command is invoked. The relevant code can be found at line 172ff, roughly, the definition of the procedure 'clock'. This means none of the procedures of this file belong in the tclIndex. Another indicator that automatic regeneration of tclIndex is ill-advised. 2009-11-24 Donal K. Fellows <dkf@users.sf.net> * generic/tclOO.c (FinalizeAlloc, Tcl_NewObjectInstance): [Bug 2903011]: Make it an error to destroy an object in a constructor, and also make sure that an object is not deleted twice in the error case. |
| ︙ | ︙ |
Changes to doc/BoolObj.3.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" Contributions from Don Porter, NIST, 2005. (not subject to US copyright) '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" Contributions from Don Porter, NIST, 2005. (not subject to US copyright) '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: BoolObj.3,v 1.3.4.5 2009/12/08 18:39:18 dgp Exp $ '\" .so man.macros .TH Tcl_BooleanObj 3 8.5 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_NewBooleanObj, Tcl_SetBooleanObj, Tcl_GetBooleanFromObj \- store/retrieve boolean value in a Tcl_Obj .SH SYNOPSIS |
| ︙ | ︙ | |||
55 56 57 58 59 60 61 | an existing Tcl_Obj, and stores in the Tcl_Obj \fI*objPtr\fR the boolean value \fIboolValue\fR. This is a write operation on \fI*objPtr\fR, so \fIobjPtr\fR must be unshared. Attempts to write to a shared Tcl_Obj will panic. A successful write of \fIboolValue\fR into \fI*objPtr\fR implies the freeing of any former value stored in \fI*objPtr\fR. .PP | | | 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 | an existing Tcl_Obj, and stores in the Tcl_Obj \fI*objPtr\fR the boolean value \fIboolValue\fR. This is a write operation on \fI*objPtr\fR, so \fIobjPtr\fR must be unshared. Attempts to write to a shared Tcl_Obj will panic. A successful write of \fIboolValue\fR into \fI*objPtr\fR implies the freeing of any former value stored in \fI*objPtr\fR. .PP \fBTcl_GetBooleanFromObj\fR attempts to retrieve a boolean value from the value stored in \fI*objPtr\fR. If \fIobjPtr\fR holds a string value recognized by \fBTcl_GetBoolean\fR, then the recognized boolean value is written at the address given by \fIboolPtr\fR. If \fIobjPtr\fR holds any value recognized as a number by Tcl, then if that value is zero a 0 is written at the address given by \fIboolPtr\fR and if that |
| ︙ | ︙ |
Changes to doc/Class.3.
1 2 3 4 5 6 | '\" '\" Copyright (c) 2007 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 2007 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: Class.3,v 1.1.2.6 2009/12/08 18:39:18 dgp Exp $ '\" .so man.macros .TH Tcl_Class 3 0.1 TclOO "TclOO Library Functions" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME Tcl_ClassGetMetadata, Tcl_ClassSetMetadata, Tcl_CopyObjectInstance, Tcl_GetClassAsObject, Tcl_GetObjectAsClass, Tcl_GetObjectCommand, Tcl_GetObjectNamespace, Tcl_NewObjectInstance, Tcl_ObjectDeleted, Tcl_ObjectGetMetadata, Tcl_ObjectGetMethodNameMapper, Tcl_ObjectSetMetadata, Tcl_ObjectSetMethodNameMapper \- manipulate objects and classes |
| ︙ | ︙ | |||
112 113 114 115 116 117 118 | function. Note that the Tcl_Obj reference returned by \fBTcl_GetObjectName\fR is a shared reference. .PP Instances of classes are created using \fBTcl_NewObjectInstance\fR, which takes creates an object from any class (and which is internally called by both the \fBcreate\fR and \fBnew\fR methods of the \fBoo::class\fR class). It takes parameters that optionally give the name of the object and namespace to | | | 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 | function. Note that the Tcl_Obj reference returned by \fBTcl_GetObjectName\fR is a shared reference. .PP Instances of classes are created using \fBTcl_NewObjectInstance\fR, which takes creates an object from any class (and which is internally called by both the \fBcreate\fR and \fBnew\fR methods of the \fBoo::class\fR class). It takes parameters that optionally give the name of the object and namespace to create, and which describe the arguments to pass to the class's constructor (if any). The result of the function will be either a reference to the newly created object, or NULL if the creation failed (when an error message will be left in the interpreter result). In addition, objects may be copied by using \fBTcl_CopyObjectInstance\fR which creates a copy of an object without running any constructors. .SH "OBJECT AND CLASS METADATA" .PP |
| ︙ | ︙ |
Changes to doc/CrtChannel.3.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" Copyright (c) 1997-2000 Ajuba Solutions. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" Copyright (c) 1997-2000 Ajuba Solutions. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: CrtChannel.3,v 1.16.4.16 2009/12/08 18:39:18 dgp Exp $ .so man.macros .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_ChannelTruncateProc, Tcl_ChannelSetOptionProc, Tcl_ChannelGetOptionProc, Tcl_ChannelWatchProc, Tcl_ChannelGetHandleProc, Tcl_ChannelFlushProc, Tcl_ChannelHandlerProc, Tcl_ChannelThreadActionProc, Tcl_IsChannelShared, Tcl_IsChannelRegistered, Tcl_CutChannel, Tcl_SpliceChannel, Tcl_IsChannelExisting, Tcl_ClearChannelHandlers, Tcl_GetChannelThread, Tcl_ChannelBuffered \- procedures for creating and manipulating channels .SH SYNOPSIS |
| ︙ | ︙ | |||
295 296 297 298 299 300 301 | \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. 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. .PP | | | 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 | \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. 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. .PP \fBTcl_ClearChannelHandlers\fR removes all channel handlers and event scripts associated with the specified \fIchannel\fR, thus shutting down all event processing for this channel. .SH TCL_CHANNELTYPE .PP A channel driver provides a \fBTcl_ChannelType\fR structure that contains pointers to functions that implement the various operations on a channel; these operations are invoked as needed by the generic layer. The structure |
| ︙ | ︙ | |||
371 372 373 374 375 376 377 | 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 the version of the structure that you require. \fBTCL_CHANNEL_VERSION_2\fR is the minimum recommended. | | | | | 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 | 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 the version of the structure that you require. \fBTCL_CHANNEL_VERSION_2\fR is the minimum recommended. \fBTCL_CHANNEL_VERSION_3\fR must be set to specify the \fIwideSeekProc\fR member. \fBTCL_CHANNEL_VERSION_4\fR must be set to specify the \fIthreadActionProc\fR member (includes \fIwideSeekProc\fR). \fBTCL_CHANNEL_VERSION_5\fR must be set to specify the \fItruncateProc\fR members (includes \fIwideSeekProc\fR and \fIthreadActionProc\fR). 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 structures, stacked channels must be of at least \fBTCL_CHANNEL_VERSION_2\fR to function correctly. |
| ︙ | ︙ | |||
422 423 424 425 426 427 428 | This value can be retrieved with \fBTcl_ChannelBlockModeProc\fR, which returns a pointer to the function. .PP A channel driver \fBnot\fR supplying a \fIblockModeProc\fR has to be very, very careful. It has to tell the generic layer exactly which blocking mode is acceptable to it, and should this also document for the user so that the blocking mode of the channel is not changed to an | | | 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 | This value can be retrieved with \fBTcl_ChannelBlockModeProc\fR, which returns a pointer to the function. .PP A channel driver \fBnot\fR supplying a \fIblockModeProc\fR has to be very, very careful. It has to tell the generic layer exactly which blocking mode is acceptable to it, and should this also document for the user so that the blocking mode of the channel is not changed to an unacceptable value. Any confusion here may lead the interpreter into a (spurious and difficult to find) deadlock. .SS "CLOSEPROC AND CLOSE2PROC" .PP The \fIcloseProc\fR field contains the address of a function called by the generic layer to clean up driver-related information when the channel is closed. \fICloseProc\fR must match the following prototype: .PP |
| ︙ | ︙ |
Changes to doc/DictObj.3.
1 2 3 4 5 6 | '\" '\" Copyright (c) 2003 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 2003 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: DictObj.3,v 1.1.2.8 2009/12/08 18:39:18 dgp Exp $ '\" .so man.macros .TH Tcl_DictObj 3 8.5 Tcl "Tcl Library Procedures" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME Tcl_NewDictObj, Tcl_DictObjPut, Tcl_DictObjGet, Tcl_DictObjRemove, Tcl_DictObjSize, Tcl_DictObjFirst, Tcl_DictObjNext, Tcl_DictObjDone, Tcl_DictObjPutKeyList, Tcl_DictObjRemoveKeyList \- manipulate Tcl objects as dictionaries |
| ︙ | ︙ | |||
101 102 103 104 105 106 107 | Tcl dictionary objects have an internal representation that supports efficient mapping from keys to values and which guarantees that the particular ordering of keys within the dictionary remains the same modulo any keys being deleted (which removes them from the order) or added (which adds them to the end of the order). If reinterpreted as a list, the values at the even-valued indices in the list will be the keys of the dictionary, and each will be followed (in the odd-valued | | | 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 | Tcl dictionary objects have an internal representation that supports efficient mapping from keys to values and which guarantees that the particular ordering of keys within the dictionary remains the same modulo any keys being deleted (which removes them from the order) or added (which adds them to the end of the order). If reinterpreted as a list, the values at the even-valued indices in the list will be the keys of the dictionary, and each will be followed (in the odd-valued index) by the value associated with that key. .PP The procedures described in this man page are used to create, modify, index, and iterate over dictionary objects from C code. .PP \fBTcl_NewDictObj\fR creates a new, empty dictionary object. The string representation of the object will be invalid, and the reference count of the object will be zero. |
| ︙ | ︙ |
Changes to doc/DoubleObj.3.
1 2 3 4 5 6 | '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: DoubleObj.3,v 1.2.42.3 2009/12/08 18:39:18 dgp Exp $ '\" .so man.macros .TH Tcl_DoubleObj 3 8.0 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_NewDoubleObj, Tcl_SetDoubleObj, Tcl_GetDoubleFromObj \- manipulate Tcl objects as floating-point values .SH SYNOPSIS |
| ︙ | ︙ | |||
48 49 50 51 52 53 54 | \fBTcl_SetDoubleObj\fR sets the value of an existing Tcl object pointed to by \fIobjPtr\fR to the double value \fIdoubleValue\fR. The \fIobjPtr\fR argument must point to an unshared Tcl object. Any attempt to set the value of a shared Tcl object violates Tcl's copy-on-write policy. Any existing string representation or internal representation in the unshared Tcl object will be freed as a consequence of setting the new value. .PP | | | 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 | \fBTcl_SetDoubleObj\fR sets the value of an existing Tcl object pointed to by \fIobjPtr\fR to the double value \fIdoubleValue\fR. The \fIobjPtr\fR argument must point to an unshared Tcl object. Any attempt to set the value of a shared Tcl object violates Tcl's copy-on-write policy. Any existing string representation or internal representation in the unshared Tcl object will be freed as a consequence of setting the new value. .PP \fBTcl_GetDoubleFromObj\fR attempts to retrieve a double value from the Tcl object \fIobjPtr\fR. If the attempt succeeds, then \fBTCL_OK\fR is returned, and the double value is written to the storage pointed to by \fIdoublePtr\fR. If the attempt fails, then \fBTCL_ERROR\fR is returned, and if \fIinterp\fR is non-NULL, an error message is left in \fIinterp\fR. The \fBTcl_ObjType\fR of \fIobjPtr\fR may be changed to make subsequent calls to \fBTcl_GetDoubleFromObj\fR more efficient. '\" TODO: add discussion of treatment of NaN value .SH "SEE ALSO" Tcl_NewObj, Tcl_DecrRefCount, Tcl_IncrRefCount, Tcl_GetObjResult .SH KEYWORDS double, double object, double type, internal representation, object, object type, string representation |
Changes to doc/Ensemble.3.
1 2 3 4 5 6 | '\" '\" Copyright (c) 2005 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 2005 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: Ensemble.3,v 1.1.4.6 2009/12/08 18:39:18 dgp Exp $ '\" '\" This documents the C API introduced in TIP#235 '\" .so man.macros .TH Tcl_Ensemble 3 8.5 Tcl "Tcl Library Procedures" .BS .SH NAME |
| ︙ | ︙ | |||
115 116 117 118 119 120 121 | that states what subcommand to execute. .PP Ensembles are created using \fBTcl_CreateEnsemble\fR, which takes four arguments: the interpreter to work within, the name of the ensemble to create, the namespace within the interpreter to bind the ensemble to, and the default set of ensemble flags. The result of the function is the command token for the ensemble, which may be used to further | | | 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 | that states what subcommand to execute. .PP Ensembles are created using \fBTcl_CreateEnsemble\fR, which takes four arguments: the interpreter to work within, the name of the ensemble to create, the namespace within the interpreter to bind the ensemble to, and the default set of ensemble flags. The result of the function is the command token for the ensemble, which may be used to further configure the ensemble using the API described below in \fBENSEMBLE PROPERTIES\fR. .PP Given the name of an ensemble command, the token for that command may be retrieved using \fBTcl_FindEnsemble\fR. If the given command name (in \fIcmdNameObj\fR) does not refer to an ensemble command, the result of the function is NULL and (if the TCL_LEAVE_ERR_MSG bit is set in \fIflags\fR) an error message is left in the interpreter |
| ︙ | ︙ | |||
161 162 163 164 165 166 167 | ensemble) and the dictionary obtained from \fBTcl_GetEnsembleMappingDict\fR should always be treated as immutable even if it is unshared. .TP \fBformal pre-subcommand parameter list\fR (read-write) .VS 8.6 A list of formal parameter names (the names only being used when generating | | | | 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 | ensemble) and the dictionary obtained from \fBTcl_GetEnsembleMappingDict\fR should always be treated as immutable even if it is unshared. .TP \fBformal pre-subcommand parameter list\fR (read-write) .VS 8.6 A list of formal parameter names (the names only being used when generating error messages) that come at invocation of the ensemble between the name of the ensemble and the subcommand argument. NULL (the default) is equivalent to the empty list. May be read and written using \fBTcl_GetEnsembleParameterList\fR and \fBTcl_SetEnsembleParameterList\fR respectively. The result of both of those functions is a Tcl result code (TCL_OK, or TCL_ERROR if the token does not refer to an ensemble) and the dictionary obtained from \fBTcl_GetEnsembleParameterList\fR should always be treated as immutable even if it is unshared. .VE 8.6 .TP \fBsubcommand list\fR (read-write) . A list of all the subcommand names for the ensemble, or NULL if this is to be derived from either the keys of the mapping dictionary (see above) or (if that is also NULL) from the set of commands exported by the bound namespace. May be read and written using \fBTcl_GetEnsembleSubcommandList\fR and \fBTcl_SetEnsembleSubcommandList\fR respectively. The result of both of those functions is a Tcl result code (TCL_OK, or TCL_ERROR if the token does not refer to an ensemble) and the list obtained from \fBTcl_GetEnsembleSubcommandList\fR should always be treated as immutable even if it is unshared. .TP \fBunknown subcommand handler command prefix\fR (read-write) . A list of words to prepend on the front of any subcommand when the subcommand is unknown to the ensemble (according to the current prefix handling rule); see the \fBnamespace ensemble\fR command for more |
| ︙ | ︙ |
Changes to doc/Environment.3.
1 2 3 4 5 6 | '\" '\" Copyright (c) 1997-1998 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | | > < | > > | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 | '\" '\" Copyright (c) 1997-1998 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: Environment.3,v 1.1.20.4 2009/12/08 18:39:18 dgp Exp $ '\" .so man.macros .TH Tcl_PutEnv 3 "7.5" Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_PutEnv \- procedures to manipulate the environment .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp int \fBTcl_PutEnv\fR(\fIassignment\fR) .SH ARGUMENTS .AS "const char" *assignment .AP "const char" *assignment in Info about environment variable in the format .QW \fINAME\fB=\fIvalue\fR . The \fIassignment\fR argument is in the system encoding. .BE .SH DESCRIPTION .PP \fBTcl_PutEnv\fR sets an environment variable. The information is passed in a single string of the form .QW \fINAME\fB=\fIvalue\fR . This procedure is intended to be a stand-in for the UNIX \fBputenv\fR system call. All Tcl-based applications using \fBputenv\fR should redefine it to \fBTcl_PutEnv\fR so that they will interface properly to the Tcl runtime. .SH "SEE ALSO" tclvars(n) .SH KEYWORDS environment, variable |
Changes to doc/FileSystem.3.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 2001 Vincent Darley '\" Copyright (c) 2008 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 2001 Vincent Darley '\" Copyright (c) 2008 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: FileSystem.3,v 1.32.4.25 2009/12/08 18:39:18 dgp Exp $ '\" .so man.macros .TH Filesystem 3 8.4 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_FSRegister, Tcl_FSUnregister, Tcl_FSData, Tcl_FSMountsChanged, Tcl_FSGetFileSystemForPath, Tcl_FSGetPathType, Tcl_FSCopyFile, Tcl_FSCopyDirectory, Tcl_FSCreateDirectory, Tcl_FSDeleteFile, Tcl_FSRemoveDirectory, Tcl_FSRenameFile, Tcl_FSListVolumes, Tcl_FSEvalFile, Tcl_FSEvalFileEx, Tcl_FSLoadFile, Tcl_FSMatchInDirectory, Tcl_FSLink, Tcl_FSLstat, Tcl_FSUtime, Tcl_FSFileAttrsGet, Tcl_FSFileAttrsSet, Tcl_FSFileAttrStrings, Tcl_FSStat, Tcl_FSAccess, Tcl_FSOpenFileChannel, Tcl_FSGetCwd, Tcl_FSChdir, Tcl_FSPathSeparator, Tcl_FSJoinPath, Tcl_FSSplitPath, Tcl_FSEqualPaths, Tcl_FSGetNormalizedPath, Tcl_FSJoinToPath, Tcl_FSConvertToPathType, Tcl_FSGetInternalRep, Tcl_FSGetTranslatedPath, Tcl_FSGetTranslatedStringPath, Tcl_FSNewNativePath, Tcl_FSGetNativePath, Tcl_FSFileSystemInfo, Tcl_GetAccessTimeFromStat, Tcl_GetBlockSizeFromStat, Tcl_GetBlocksFromStat, Tcl_GetChangeTimeFromStat, Tcl_GetDeviceTypeFromStat, Tcl_GetFSDeviceFromStat, Tcl_GetFSInodeFromStat, Tcl_GetGroupIdFromStat, Tcl_GetLinkCountFromStat, Tcl_GetModeFromStat, Tcl_GetModificationTimeFromStat, Tcl_GetSizeFromStat, Tcl_GetUserIdFromStat, Tcl_AllocStatBuf \- procedures to interact with any filesystem .SH SYNOPSIS |
| ︙ | ︙ | |||
196 197 198 199 200 201 202 | As for \fIpathPtr\fR, but used for the source file for a copy or rename operation. .AP Tcl_Obj *destPathPtr in As for \fIpathPtr\fR, but used for the destination filename for a copy or rename operation. .AP "const char" *encodingName in The encoding of the data stored in the | | | 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 | As for \fIpathPtr\fR, but used for the source file for a copy or rename operation. .AP Tcl_Obj *destPathPtr in As for \fIpathPtr\fR, but used for the destination filename for a copy or rename operation. .AP "const char" *encodingName in The encoding of the data stored in the file identified by \fIpathPtr\fR and to be evaluated. .AP "const char" *pattern in Only files or directories matching this pattern will be returned. .AP Tcl_GlobTypeData *types in Only files or directories matching the type descriptions contained in this structure will be returned. This parameter may be NULL. .AP Tcl_Interp *interp in Interpreter to use either for results, evaluation, or reporting error |
| ︙ | ︙ | |||
946 947 948 949 950 951 952 |
NULL,
/* No rename file; use the core fallback mechanism */
NULL,
/* No copy directory; use the core fallback mechanism */
NULL,
/* Core will use stat for lstat */
NULL,
| | | 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 |
NULL,
/* No rename file; use the core fallback mechanism */
NULL,
/* No copy directory; use the core fallback mechanism */
NULL,
/* Core will use stat for lstat */
NULL,
/* No load; use the core fallback mechanism */
NULL,
/* We don't need a getcwd or chdir; the core's own
* internal value is suitable */
NULL,
NULL
};
.CE
|
| ︙ | ︙ | |||
1358 1359 1360 1361 1362 1363 1364 | .PP The called function may either return an array of strings, or may instead return NULL and place a Tcl list into the given \fIobjPtrRef\fR. Tcl will take that list and first increment its reference count before using it. On completion of that use, Tcl will decrement its reference count. Hence if the list should be disposed of by Tcl when done, it should have a reference count of zero, and if the list should not be disposed of, the | | | 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 | .PP The called function may either return an array of strings, or may instead return NULL and place a Tcl list into the given \fIobjPtrRef\fR. Tcl will take that list and first increment its reference count before using it. On completion of that use, Tcl will decrement its reference count. Hence if the list should be disposed of by Tcl when done, it should have a reference count of zero, and if the list should not be disposed of, the filesystem should ensure it returns an object with a reference count of at least one. .SS FILEATTRSGETPROC .PP Function to process a \fBTcl_FSFileAttrsGet\fR call, used by \fBfile attributes\fR. .PP .CS |
| ︙ | ︙ | |||
1428 1429 1430 1431 1432 1433 1434 | The return value is a standard Tcl result indicating whether an error occurred in the process. If successful, the directory specified by \fIpathPtr\fR should have been removed from the filesystem. If the \fIrecursive\fR flag is given, then a non-empty directory should be deleted without error. If this flag is not given, then and the directory is non-empty a POSIX .QW EEXIST | | | 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 | The return value is a standard Tcl result indicating whether an error occurred in the process. If successful, the directory specified by \fIpathPtr\fR should have been removed from the filesystem. If the \fIrecursive\fR flag is given, then a non-empty directory should be deleted without error. If this flag is not given, then and the directory is non-empty a POSIX .QW EEXIST error should be signaled. If an error does occur, the name of the file or directory which caused the error should be placed in \fIerrorPtr\fR. .SS DELETEFILEPROC .PP Function to process a \fBTcl_FSDeleteFile\fR call. Should be implemented unless the FS is read-only. .PP |
| ︙ | ︙ |
Changes to doc/Hash.3.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: Hash.3,v 1.10.4.15 2009/12/08 18:39:18 dgp Exp $ '\" .so man.macros .TH Tcl_Hash 3 "" Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_InitHashTable, Tcl_InitCustomHashTable, Tcl_InitObjHashTable, Tcl_DeleteHashTable, Tcl_CreateHashEntry, Tcl_DeleteHashEntry, Tcl_FindHashEntry, Tcl_GetHashValue, Tcl_SetHashValue, Tcl_GetHashKey, Tcl_FirstHashEntry, Tcl_NextHashEntry, Tcl_HashStats \- procedures to manage hash tables .SH SYNOPSIS |
| ︙ | ︙ | |||
217 218 219 220 221 222 223 | empty). Each subsequent call to \fBTcl_NextHashEntry\fR returns the next entry in the table or NULL if the end of the table has been reached. A call to \fBTcl_FirstHashEntry\fR followed by calls to \fBTcl_NextHashEntry\fR will return each of the entries in the table exactly once, in an arbitrary order. | | | 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 | empty). Each subsequent call to \fBTcl_NextHashEntry\fR returns the next entry in the table or NULL if the end of the table has been reached. A call to \fBTcl_FirstHashEntry\fR followed by calls to \fBTcl_NextHashEntry\fR will return each of the entries in the table exactly once, in an arbitrary order. It is inadvisable to modify the structure of the table, e.g. by creating or deleting entries, while the search is in progress, with the exception of deleting the entry returned by \fBTcl_FirstHashEntry\fR or \fBTcl_NextHashEntry\fR. .PP \fBTcl_HashStats\fR returns a dynamically-allocated string with overall information about a hash table, such as the number of entries it contains, the number of buckets in its hash array, |
| ︙ | ︙ |
Changes to doc/IntObj.3.
1 2 3 4 5 6 | '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: IntObj.3,v 1.3.4.8 2009/12/08 18:39:18 dgp Exp $ '\" .so man.macros .TH Tcl_IntObj 3 8.5 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_NewIntObj, Tcl_NewLongObj, Tcl_NewWideIntObj, Tcl_SetIntObj, Tcl_SetLongObj, Tcl_SetWideIntObj, Tcl_GetIntFromObj, Tcl_GetLongFromObj, Tcl_GetWideIntFromObj, Tcl_NewBignumObj, Tcl_SetBignumObj, Tcl_GetBignumFromObj, Tcl_TakeBignumFromObj \- manipulate Tcl objects as integer values .SH SYNOPSIS |
| ︙ | ︙ | |||
87 88 89 90 91 92 93 | used to initialize a multi-precision integer value. .BE .SH DESCRIPTION .PP These procedures are used to create, modify, and read Tcl objects that hold integral values. .PP | | | 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 | used to initialize a multi-precision integer value. .BE .SH DESCRIPTION .PP These procedures are used to create, modify, and read Tcl objects that hold integral values. .PP The different routines exist to accommodate different integral types in C with which values might be exchanged. The C integral types for which Tcl provides value exchange routines are \fBint\fR, \fBlong int\fR, \fBTcl_WideInt\fR, and \fBmp_int\fR. The \fBint\fR and \fBlong int\fR types are provided by the C language standard. The \fBTcl_WideInt\fR type is a typedef defined to be whatever signed integral type covers at least the 64-bit integer range (-9223372036854775808 to 9223372036854775807). Depending on the platform and the C compiler, the actual type might be |
| ︙ | ︙ |
Changes to doc/Limit.3.
1 2 3 4 5 6 | '\" '\" Copyright (c) 2004 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 2004 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: Limit.3,v 1.2.2.6 2009/12/08 18:39:18 dgp Exp $ '\" .so man.macros .TH Tcl_LimitCheck 3 8.5 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_LimitAddHandler, Tcl_LimitCheck, Tcl_LimitExceeded, Tcl_LimitGetCommands, Tcl_LimitGetGranularity, Tcl_LimitGetTime, Tcl_LimitReady, Tcl_LimitRemoveHandler, Tcl_LimitSetCommands, Tcl_LimitSetGranularity, Tcl_LimitSetTime, Tcl_LimitTypeEnabled, Tcl_LimitTypeExceeded, Tcl_LimitTypeReset, Tcl_LimitTypeSet \- manage and check resource limits on interpreters .SH SYNOPSIS |
| ︙ | ︙ | |||
165 166 167 168 169 170 171 |
.CS
typedef void \fBTcl_LimitHandlerProc\fR(
ClientData \fIclientData\fR,
Tcl_Interp *\fIinterp\fR);
.CE
.PP
The \fIclientData\fR argument to the handler will be whatever is
| | | 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 |
.CS
typedef void \fBTcl_LimitHandlerProc\fR(
ClientData \fIclientData\fR,
Tcl_Interp *\fIinterp\fR);
.CE
.PP
The \fIclientData\fR argument to the handler will be whatever is
passed to the \fIclientData\fR argument to \fBTcl_LimitAddHandler\fR,
and the \fIinterp\fR is the interpreter that had its limit exceeded.
.PP
The \fIdeleteProc\fR argument to \fBTcl_LimitAddHandler\fR is a
function to call to delete the \fIclientData\fR value. It may be
\fBTCL_STATIC\fR or NULL if no deletion action is necessary, or
\fBTCL_DYNAMIC\fR if all that is necessary is to free the structure with
\fBTcl_Free\fR. Otherwise, it should refer to a function with the
|
| ︙ | ︙ |
Changes to doc/Method.3.
1 2 3 4 5 6 | '\" '\" Copyright (c) 2007 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 2007 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: Method.3,v 1.1.2.5 2009/12/08 18:39:18 dgp Exp $ '\" .so man.macros .TH Tcl_Method 3 0.1 TclOO "TclOO Library Functions" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME Tcl_ClassSetConstructor, Tcl_ClassSetDestructor, Tcl_MethodDeclarerClass, Tcl_MethodDeclarerObject, Tcl_MethodIsPublic, Tcl_MethodIsType, Tcl_MethodName, Tcl_NewInstanceMethod, Tcl_NewMethod, Tcl_ObjectContextIsFiltering, Tcl_ObjectContextMethod, Tcl_ObjectContextObject, Tcl_ObjectContextSkippedArgs \- manipulate methods and method-call contexts |
| ︙ | ︙ | |||
127 128 129 130 131 132 133 | unnamed method is created, which is used for constructors and destructors. Constructors should be installed into their class using the \fBTcl_ClassSetConstructor\fR function, and destructors (which must not require any arguments) should be installed into their class using the \fBTcl_ClassSetDestructor\fR function. Unnamed methods should not be used for any other purpose, and named methods should not be used as either constructors or destructors. Also note that a NULL \fImethodTypePtr\fR is used to provide | | | 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 | unnamed method is created, which is used for constructors and destructors. Constructors should be installed into their class using the \fBTcl_ClassSetConstructor\fR function, and destructors (which must not require any arguments) should be installed into their class using the \fBTcl_ClassSetDestructor\fR function. Unnamed methods should not be used for any other purpose, and named methods should not be used as either constructors or destructors. Also note that a NULL \fImethodTypePtr\fR is used to provide internal signaling, and should not be used in client code. .SS "METHOD CALL CONTEXTS" .PP When a method is called, a method-call context reference is passed in as one of the arguments to the implementation function. This context can be inspected to provide information about the caller, but should not be retained beyond the moment when the method call terminates. .PP |
| ︙ | ︙ |
Changes to doc/NRE.3.
1 | .\" | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | .\" .\" Copyright (c) 2008 by Kevin B. Kenny. .\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: NRE.3,v 1.1.2.7 2009/12/08 18:39:18 dgp Exp $ '\" .so man.macros .TH NRE 3 8.6 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_NRCreateCommand, Tcl_NRCallObjProc, Tcl_NREvalObj, Tcl_NREvalObjv, Tcl_NRCmdSwap, Tcl_NRAddCallback \- Non-Recursive (stackless) evaluation of Tcl scripts. .SH SYNOPSIS |
| ︙ | ︙ |
Changes to doc/ObjectType.3.
1 2 3 4 5 6 | '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: ObjectType.3,v 1.7.4.10 2009/12/08 18:39:18 dgp Exp $ '\" .so man.macros .TH Tcl_ObjType 3 8.0 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_RegisterObjType, Tcl_GetObjType, Tcl_AppendAllObjTypes, Tcl_ConvertToType \- manipulate Tcl object types .SH SYNOPSIS |
| ︙ | ︙ | |||
96 97 98 99 100 101 102 | .VE 8.5 .SH "THE TCL_OBJTYPE STRUCTURE" .PP Extension writers can define new object types by defining four procedures and initializing a Tcl_ObjType structure to describe the type. Extension writers may also pass a pointer to their Tcl_ObjType | | | 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 |
.VE 8.5
.SH "THE TCL_OBJTYPE STRUCTURE"
.PP
Extension writers can define new object types by defining four
procedures and
initializing a Tcl_ObjType structure to describe the type.
Extension writers may also pass a pointer to their Tcl_ObjType
structure to \fBTcl_RegisterObjType\fR if they wish to permit
other extensions to look up their Tcl_ObjType by name with
the \fBTcl_GetObjType\fR routine.
The \fBTcl_ObjType\fR structure is defined as follows:
.PP
.CS
typedef struct Tcl_ObjType {
const char *\fIname\fR;
|
| ︙ | ︙ |
Changes to doc/PkgRequire.3.
1 2 3 4 5 6 | '\" '\" Copyright (c) 1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: PkgRequire.3,v 1.6.4.5 2009/12/08 18:39:18 dgp Exp $ '\" .so man.macros .TH Tcl_PkgRequire 3 7.5 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_PkgRequire, Tcl_PkgRequireEx, Tcl_PkgRequireProc, Tcl_PkgPresent, Tcl_PkgPresentEx, Tcl_PkgProvide, Tcl_PkgProvideEx \- package version control .SH SYNOPSIS |
| ︙ | ︙ | |||
87 88 89 90 91 92 93 | \fBTcl_PkgProvideEx\fR, \fBTcl_PkgPresentEx\fR and \fBTcl_PkgRequireEx\fR allow the setting and retrieving of the client data associated with the package. In all other respects they are equivalent to the matching functions. .PP \fBTcl_PkgRequireProc\fR is the form of \fBpackage require\fR handling multiple requirements. The other forms are present for backward | | | 87 88 89 90 91 92 93 94 95 96 97 98 | \fBTcl_PkgProvideEx\fR, \fBTcl_PkgPresentEx\fR and \fBTcl_PkgRequireEx\fR allow the setting and retrieving of the client data associated with the package. In all other respects they are equivalent to the matching functions. .PP \fBTcl_PkgRequireProc\fR is the form of \fBpackage require\fR handling multiple requirements. The other forms are present for backward compatibility and translate their invocations to this form. .SH KEYWORDS package, present, provide, require, version .SH "SEE ALSO" package(n), Tcl_StaticPackage(3) |
Changes to doc/SetChanErr.3.
1 2 3 4 5 6 | '\" '\" Copyright (c) 2005 Andreas Kupries <andreas_kupries@users.sourceforge.net> '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 2005 Andreas Kupries <andreas_kupries@users.sourceforge.net> '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: SetChanErr.3,v 1.1.4.6 2009/12/08 18:39:18 dgp Exp $ .so man.macros .TH Tcl_SetChannelError 3 8.5 Tcl "Tcl Library Procedures" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME Tcl_SetChannelError, Tcl_SetChannelErrorInterp, Tcl_GetChannelError, Tcl_GetChannelErrorInterp \- functions to create/intercept Tcl errors by channel drivers. .SH SYNOPSIS |
| ︙ | ︙ | |||
64 65 66 67 68 69 70 | the specified interpreter. The number of references to the \fBmsg\fR object goes up by one. Previously stored information will be discarded, by releasing the reference held by the interpreter. The interpreter reference must not be NULL. .PP \fBTcl_GetChannelError\fR places either the error message held in the bypass area of the specified channel into \fImsgPtr\fR, or NULL; and resets the | | | | | | 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 | the specified interpreter. The number of references to the \fBmsg\fR object goes up by one. Previously stored information will be discarded, by releasing the reference held by the interpreter. The interpreter reference must not be NULL. .PP \fBTcl_GetChannelError\fR places either the error message held in the bypass area of the specified channel into \fImsgPtr\fR, or NULL; and resets the bypass, that is, after an invocation all following invocations will return NULL, until an intervening invocation of \fBTcl_SetChannelError\fR with a non-NULL message. The \fImsgPtr\fR must not be NULL. The reference count of the message is not touched. The reference previously held by the channel is now held by the caller of the function and it is its responsibility to release that reference when it is done with the object. .PP \fBTcl_GetChannelErrorInterp\fR places either the error message held in the bypass area of the specified interpreter into \fImsgPtr\fR, or NULL; and resets the bypass, that is, after an invocation all following invocations will return NULL, until an intervening invocation of \fBTcl_SetChannelErrorInterp\fR with a non-NULL message. The \fImsgPtr\fR must not be NULL. The reference count of the message is not touched. The reference previously held by the interpreter is now held by the caller of the function and it is its responsibility to release that reference when it is done with the object. .PP Which functions of a channel driver are allowed to use which bypass function |
| ︙ | ︙ |
Changes to doc/SetResult.3.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: SetResult.3,v 1.7.4.10 2009/12/08 18:39:18 dgp Exp $ '\" .so man.macros .TH Tcl_SetResult 3 8.0 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_SetObjResult, Tcl_GetObjResult, Tcl_SetResult, Tcl_GetStringResult, Tcl_AppendResult, Tcl_AppendResultVA, Tcl_AppendElement, Tcl_ResetResult, Tcl_TransferResult, Tcl_FreeResult \- manipulate Tcl result .SH SYNOPSIS |
| ︙ | ︙ | |||
145 146 147 148 149 150 151 | its \fIresult\fR arguments. \fBTcl_AppendResult\fR may be called repeatedly as additional pieces of the result are produced. \fBTcl_AppendResult\fR takes care of all the storage management issues associated with managing \fIinterp\fR's result, such as allocating a larger result area if necessary. It also manages conversion to and from the \fIresult\fR field of the | | | 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 | its \fIresult\fR arguments. \fBTcl_AppendResult\fR may be called repeatedly as additional pieces of the result are produced. \fBTcl_AppendResult\fR takes care of all the storage management issues associated with managing \fIinterp\fR's result, such as allocating a larger result area if necessary. It also manages conversion to and from the \fIresult\fR field of the \fIinterp\fR so as to handle backward-compatibility with old-style extensions. Any number of \fIresult\fR arguments may be passed in a single call; the last argument in the list must be a NULL pointer. .PP \fBTcl_AppendResultVA\fR is the same as \fBTcl_AppendResult\fR except that instead of taking a variable number of arguments it takes an argument list. .PP |
| ︙ | ︙ |
Changes to doc/Tcl.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: Tcl.n,v 1.9.4.9 2009/12/08 18:39:18 dgp Exp $ '\" .so man.macros .TH Tcl n "8.5" Tcl "Tcl Built-In Commands" .BS .SH NAME Tcl \- Tool Command Language .SH SYNOPSIS |
| ︙ | ︙ | |||
51 52 53 54 55 56 57 |
are performed on the characters between the quotes as described below.
The double-quotes are not retained as part of the word.
.IP "[5] \fBArgument expansion.\fR"
If a word starts with the string
.QW {*}
followed by a non-whitespace character, then the leading
.QW {*}
| < | | > > | | | | 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 |
are performed on the characters between the quotes as described below.
The double-quotes are not retained as part of the word.
.IP "[5] \fBArgument expansion.\fR"
If a word starts with the string
.QW {*}
followed by a non-whitespace character, then the leading
.QW {*}
is removed and the rest of the word is parsed and substituted as any other
word. After substitution, the word is parsed as a list (without command or
variable substitutions; backslash substitutions are performed as is normal for
a list and individual internal words may be surrounded by either braces or
double-quote characters), and its words are added to the command being
substituted. For instance,
.QW "cmd a {*}{b [c]} d {*}{$e f \"g h\"}"
is equivalent to
.QW "cmd a b {[c]} d {$e} f \"g h\"" .
.IP "[6] \fBBraces.\fR"
If the first character of a word is an open brace
.PQ {
and rule [5] does not apply, then
the word is terminated by the matching close brace
.PQ } "" .
Braces nest within the word: for each additional open
|
| ︙ | ︙ |
Changes to generic/tcl.h.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 | * Copyright (c) 1994-1998 Sun Microsystems, Inc. * Copyright (c) 1998-2000 by Scriptics Corporation. * Copyright (c) 2002 by Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | * Copyright (c) 1994-1998 Sun Microsystems, Inc. * Copyright (c) 1998-2000 by Scriptics Corporation. * Copyright (c) 2002 by Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tcl.h,v 1.157.2.79 2009/12/08 18:39:18 dgp Exp $ */ #ifndef _TCL #define _TCL /* * For C++ compilers, use extern "C" |
| ︙ | ︙ | |||
2305 2306 2307 2308 2309 2310 2311 | /* * The following function is required to be defined in all stubs aware * extensions. The function is actually implemented in the stub library, not * the main Tcl library, although there is a trivial implementation in the * main library in case an extension is statically linked into an application. */ | | | | 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 | /* * The following function is required to be defined in all stubs aware * extensions. The function is actually implemented in the stub library, not * the main Tcl library, although there is a trivial implementation in the * main library in case an extension is statically linked into an application. */ const char * Tcl_InitStubs(Tcl_Interp *interp, const char *version, int exact); const char * TclTomMathInitializeStubs(Tcl_Interp *interp, const char *version, int epoch, int revision); #ifndef USE_TCL_STUBS /* * When not using stubs, make it a macro. */ |
| ︙ | ︙ |
Changes to generic/tclBasic.c.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 | * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net> * Copyright (c) 2006-2008 by Joe Mistachkin. All rights reserved. * Copyright (c) 2008 Miguel Sofer <msofer@users.sourceforge.net> * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | < < | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 | * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net> * Copyright (c) 2006-2008 by Joe Mistachkin. All rights reserved. * Copyright (c) 2008 Miguel Sofer <msofer@users.sourceforge.net> * * 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.82.2.145 2009/12/08 18:39:18 dgp Exp $ */ #include "tclInt.h" #include "tclOOInt.h" #include "tclCompile.h" #include <float.h> #include <limits.h> #include <math.h> #include "tommath.h" #if NRE_ENABLE_ASSERTS #include <assert.h> #endif #define INTERP_STACK_INITIAL_SIZE 2000 #define CORO_STACK_INITIAL_SIZE 200 /* * Determine whether we're using IEEE floating point */ #if (FLT_RADIX == 2) && (DBL_MANT_DIG == 53) && (DBL_MAX_EXP == 1024) # define IEEE_FLOATING_POINT |
| ︙ | ︙ | |||
141 142 143 144 145 146 147 148 149 150 151 152 153 154 |
static Tcl_NRPostProc TEOEx_ListCallback;
static Tcl_NRPostProc TEOEx_ByteCodeCallback;
static Tcl_NRPostProc NRRunObjProc;
static Tcl_NRPostProc TailcallCleanup;
static Tcl_NRPostProc NRTailcallEval;
/*
* The following structure define the commands in the Tcl core.
*/
typedef struct {
const char *name; /* Name of object-based command. */
| > | 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 |
static Tcl_NRPostProc TEOEx_ListCallback;
static Tcl_NRPostProc TEOEx_ByteCodeCallback;
static Tcl_NRPostProc NRRunObjProc;
static Tcl_NRPostProc TailcallCleanup;
static Tcl_NRPostProc NRTailcallEval;
static Tcl_NRPostProc YieldCallback;
/*
* The following structure define the commands in the Tcl core.
*/
typedef struct {
const char *name; /* Name of object-based command. */
|
| ︙ | ︙ | |||
211 212 213 214 215 216 217 218 219 220 221 222 223 224 |
{"rename", Tcl_RenameObjCmd, NULL, NULL, 1},
{"return", Tcl_ReturnObjCmd, TclCompileReturnCmd, NULL, 1},
{"scan", Tcl_ScanObjCmd, NULL, NULL, 1},
{"set", Tcl_SetObjCmd, TclCompileSetCmd, NULL, 1},
{"split", Tcl_SplitObjCmd, NULL, NULL, 1},
{"subst", Tcl_SubstObjCmd, TclCompileSubstCmd, TclNRSubstObjCmd, 1},
{"switch", Tcl_SwitchObjCmd, TclCompileSwitchCmd, TclNRSwitchObjCmd, 1},
{"throw", Tcl_ThrowObjCmd, NULL, NULL, 1},
{"trace", Tcl_TraceObjCmd, NULL, NULL, 1},
{"try", Tcl_TryObjCmd, NULL, TclNRTryObjCmd, 1},
{"unset", Tcl_UnsetObjCmd, NULL, NULL, 1},
{"uplevel", Tcl_UplevelObjCmd, NULL, TclNRUplevelObjCmd, 1},
{"upvar", Tcl_UpvarObjCmd, TclCompileUpvarCmd, NULL, 1},
{"variable", Tcl_VariableObjCmd, TclCompileVariableCmd, NULL, 1},
| > | 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 |
{"rename", Tcl_RenameObjCmd, NULL, NULL, 1},
{"return", Tcl_ReturnObjCmd, TclCompileReturnCmd, NULL, 1},
{"scan", Tcl_ScanObjCmd, NULL, NULL, 1},
{"set", Tcl_SetObjCmd, TclCompileSetCmd, NULL, 1},
{"split", Tcl_SplitObjCmd, NULL, NULL, 1},
{"subst", Tcl_SubstObjCmd, TclCompileSubstCmd, TclNRSubstObjCmd, 1},
{"switch", Tcl_SwitchObjCmd, TclCompileSwitchCmd, TclNRSwitchObjCmd, 1},
{"tailcall", NULL, NULL, TclNRTailcallObjCmd, 1},
{"throw", Tcl_ThrowObjCmd, NULL, NULL, 1},
{"trace", Tcl_TraceObjCmd, NULL, NULL, 1},
{"try", Tcl_TryObjCmd, NULL, TclNRTryObjCmd, 1},
{"unset", Tcl_UnsetObjCmd, NULL, NULL, 1},
{"uplevel", Tcl_UplevelObjCmd, NULL, TclNRUplevelObjCmd, 1},
{"upvar", Tcl_UpvarObjCmd, TclCompileUpvarCmd, NULL, 1},
{"variable", Tcl_VariableObjCmd, TclCompileVariableCmd, NULL, 1},
|
| ︙ | ︙ | |||
787 788 789 790 791 792 793 |
*/
Tcl_CreateObjCommand(interp, "::tcl::unsupported::disassemble",
Tcl_DisassembleObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "::tcl::unsupported::representation",
Tcl_RepresentationCmd, NULL, NULL);
| < < < < | | | 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 |
*/
Tcl_CreateObjCommand(interp, "::tcl::unsupported::disassemble",
Tcl_DisassembleObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "::tcl::unsupported::representation",
Tcl_RepresentationCmd, NULL, NULL);
Tcl_NRCreateCommand(interp, "::tcl::unsupported::yieldTo", NULL,
TclNRYieldToObjCmd, NULL, NULL);
#ifdef USE_DTRACE
/*
* Register the tcl::dtrace command.
*/
Tcl_CreateObjCommand(interp, "::tcl::dtrace", DTraceObjCmd, NULL, NULL);
|
| ︙ | ︙ | |||
2181 2182 2183 2184 2185 2186 2187 |
if (!isNew) {
/*
* If the deletion callback recreated the command, just throw away
* the new command (if we try to delete it again, we could get
* stuck in an infinite loop).
*/
| | | 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 |
if (!isNew) {
/*
* If the deletion callback recreated the command, just throw away
* the new command (if we try to delete it again, we could get
* stuck in an infinite loop).
*/
ckfree(Tcl_GetHashValue(hPtr));
}
} else {
/*
* The list of command exported from the namespace might have changed.
* However, we do not need to recompute this just yet; next time we
* need the info will be soon enough.
*/
|
| ︙ | ︙ | |||
3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 |
iPtr->flags |= TCL_CANCEL_UNWIND;
}
/*
* Create the result object now so that Tcl_Canceled can avoid
* locking the cancelLock mutex.
*/
if (cancelInfo->result != NULL) {
Tcl_SetStringObj(iPtr->asyncCancelMsg, cancelInfo->result,
cancelInfo->length);
} else {
Tcl_SetObjLength(iPtr->asyncCancelMsg, 0);
}
}
| > | 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 |
iPtr->flags |= TCL_CANCEL_UNWIND;
}
/*
* Create the result object now so that Tcl_Canceled can avoid
* locking the cancelLock mutex.
*/
if (cancelInfo->result != NULL) {
Tcl_SetStringObj(iPtr->asyncCancelMsg, cancelInfo->result,
cancelInfo->length);
} else {
Tcl_SetObjLength(iPtr->asyncCancelMsg, 0);
}
}
|
| ︙ | ︙ | |||
3492 3493 3494 3495 3496 3497 3498 | * Frees allocated memory. * *---------------------------------------------------------------------- */ static void OldMathFuncDeleteProc( | | | 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 |
* Frees allocated memory.
*
*----------------------------------------------------------------------
*/
static void
OldMathFuncDeleteProc(
ClientData clientData)
{
OldMathFuncData *dataPtr = clientData;
ckfree((char *) dataPtr->argTypes);
ckfree((char *) dataPtr);
}
|
| ︙ | ︙ | |||
4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 |
case TCL_NR_BC_TYPE:
return TclExecuteByteCode(interp, data[1]);
case TCL_NR_TAILCALL_TYPE:
/* For tailcalls */
Tcl_SetResult(interp,
"tailcall can only be called from a proc or lambda",
TCL_STATIC);
return TCL_ERROR;
case TCL_NR_YIELD_TYPE:
if (iPtr->execEnvPtr->corPtr) {
Tcl_SetResult(interp, "cannot yield: C stack busy", TCL_STATIC);
| > | | > | 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 |
case TCL_NR_BC_TYPE:
return TclExecuteByteCode(interp, data[1]);
case TCL_NR_TAILCALL_TYPE:
/* For tailcalls */
Tcl_SetResult(interp,
"tailcall can only be called from a proc or lambda",
TCL_STATIC);
Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", NULL);
return TCL_ERROR;
case TCL_NR_YIELD_TYPE:
if (iPtr->execEnvPtr->corPtr) {
Tcl_SetResult(interp, "cannot yield: C stack busy", TCL_STATIC);
Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "CANT_YIELD", NULL);
} else {
Tcl_SetResult(interp, "yield can only be called in a coroutine",
TCL_STATIC);
Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD",
NULL);
}
return TCL_ERROR;
default:
Tcl_Panic("unknown call type to TEBC");
}
return result; /* not reached */
}
|
| ︙ | ︙ | |||
4837 4838 4839 4840 4841 4842 4843 |
int
TclEvalScriptTokens(
Tcl_Interp *interp,
Tcl_Token *tokenPtr,
int length,
int flags,
int line,
| | | | | | | | | | | | | | | | | | | 4836 4837 4838 4839 4840 4841 4842 4843 4844 4845 4846 4847 4848 4849 4850 4851 4852 4853 4854 4855 4856 4857 4858 4859 4860 4861 4862 4863 4864 4865 4866 |
int
TclEvalScriptTokens(
Tcl_Interp *interp,
Tcl_Token *tokenPtr,
int length,
int flags,
int line,
int* clNextOuter, /* Information about an outer context for */
CONST char* outerScript) /* continuation line data. This is set only in
* EvalTokensStandard(), to properly handle
* [...]-nested commands. The 'outerScript'
* refers to the most-outer script containing
* the embedded command, which is refered to
* by 'script'. The 'clNextOuter' refers to
* the current entry in the table of
* continuation lines in this "master script",
* and the character offsets are relative to
* the 'outerScript' as well.
*
* If outerScript == script, then this call is
* for the outer-most script/command. See
* Tcl_EvalEx() and TclEvalObjEx() for places
* generating arguments for which this is true.
*/
{
int numCommands = tokenPtr->numComponents;
Tcl_Token *scriptTokenPtr = tokenPtr;
Interp *iPtr = (Interp *) interp;
int code = TCL_OK;
unsigned int objLength = 20;
int *expand, *expandStack, *lines, *lineSpace, *linesStack;
|
| ︙ | ︙ | |||
4876 4877 4878 4879 4880 4881 4882 |
* Pointer for the tracking of invisible continuation lines. Initialized
* only if the caller gave us a table of locations to track, via
* scriptCLLocPtr. It always refers to the table entry holding the
* location of the next invisible continuation line to look for, while
* parsing the script.
*/
| | | 4875 4876 4877 4878 4879 4880 4881 4882 4883 4884 4885 4886 4887 4888 4889 |
* Pointer for the tracking of invisible continuation lines. Initialized
* only if the caller gave us a table of locations to track, via
* scriptCLLocPtr. It always refers to the table entry holding the
* location of the next invisible continuation line to look for, while
* parsing the script.
*/
int *clNext = NULL;
if (iPtr->scriptCLLocPtr) {
if (clNextOuter) {
clNext = clNextOuter;
} else {
clNext = &iPtr->scriptCLLocPtr->loc[0];
}
|
| ︙ | ︙ | |||
4994 4995 4996 4997 4998 4999 5000 | * TIP #280. Track lines within the words of the current command. * We use a separate pointer into the table of continuation line * locations to not lose our position for the per-command parsing. */ int wordLine = line; const char *wordStart = commandTokenPtr->start; | | | 4993 4994 4995 4996 4997 4998 4999 5000 5001 5002 5003 5004 5005 5006 5007 |
* TIP #280. Track lines within the words of the current command.
* We use a separate pointer into the table of continuation line
* locations to not lose our position for the per-command parsing.
*/
int wordLine = line;
const char *wordStart = commandTokenPtr->start;
int *wordCLNext = clNext;
if (length == 0) {
Tcl_Panic("EvalScriptTokens: overran token array");
}
if (tokenPtr->type != TCL_TOKEN_CMD) {
Tcl_Panic("EvalScriptTokens: invalid token array, expected cmd");
}
|
| ︙ | ︙ | |||
5352 5353 5354 5355 5356 5357 5358 | * found. * * TIP #280 *---------------------------------------------------------------------- */ void | | | | | | > > | | | 5351 5352 5353 5354 5355 5356 5357 5358 5359 5360 5361 5362 5363 5364 5365 5366 5367 5368 5369 5370 5371 5372 5373 5374 5375 5376 5377 5378 5379 5380 5381 5382 5383 5384 5385 5386 5387 5388 5389 |
* found.
*
* TIP #280
*----------------------------------------------------------------------
*/
void
TclAdvanceContinuations(
int *line,
int **clNextPtrPtr,
int loc)
{
/*
* Track the invisible continuation lines embedded in a script, if
* any. Here they are just spaces (already). They were removed by
* EvalTokensStandard() via Tcl_UtfBackslash().
*
* *clNextPtrPtr <=> We have continuation lines to track.
* **clNextPtrPtr >= 0 <=> We are not beyond the last possible location.
* loc >= **clNextPtrPtr <=> We stepped beyond the current cont. line.
*/
while (*clNextPtrPtr && (**clNextPtrPtr >= 0)
&& (loc >= **clNextPtrPtr)) {
/*
* We just stepped over an invisible continuation line. Adjust the
* line counter and step to the table entry holding the location of
* the next continuation line to track.
*/
(*line)++;
(*clNextPtrPtr)++;
}
}
/*
*----------------------------------------------------------------------
* Note: The whole data structure access for argument location tracking is
* hidden behind these three functions. The only parts open are the lineLAPtr
|
| ︙ | ︙ | |||
5526 5527 5528 5529 5530 5531 5532 | * * TIP #280 *---------------------------------------------------------------------- */ void TclArgumentBCEnter( | | | | | | | | | > | > > | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | | | | | | | > | | | | | | < | 5527 5528 5529 5530 5531 5532 5533 5534 5535 5536 5537 5538 5539 5540 5541 5542 5543 5544 5545 5546 5547 5548 5549 5550 5551 5552 5553 5554 5555 5556 5557 5558 5559 5560 5561 5562 5563 5564 5565 5566 5567 5568 5569 5570 5571 5572 5573 5574 5575 5576 5577 5578 5579 5580 5581 5582 5583 5584 5585 5586 5587 5588 5589 5590 5591 5592 5593 5594 5595 5596 5597 5598 5599 5600 5601 5602 5603 5604 5605 5606 5607 5608 5609 5610 5611 |
*
* TIP #280
*----------------------------------------------------------------------
*/
void
TclArgumentBCEnter(
Tcl_Interp *interp,
Tcl_Obj *objv[],
int objc,
void *codePtr,
CmdFrame *cfPtr,
int pc)
{
Interp *iPtr = (Interp *) interp;
Tcl_HashEntry *hePtr =
Tcl_FindHashEntry(iPtr->lineBCPtr, (char *) codePtr);
ExtCmdLoc *eclPtr;
if (!hePtr) {
return;
}
eclPtr = Tcl_GetHashValue(hePtr);
hePtr = Tcl_FindHashEntry(&eclPtr->litInfo, INT2PTR(pc));
if (hePtr) {
int word;
int cmd = PTR2INT(Tcl_GetHashValue(hePtr));
ECL *ePtr = &eclPtr->loc[cmd];
CFWordBC *lastPtr = NULL;
/*
* A few truths ...
* (1) ePtr->nline == objc
* (2) (ePtr->line[word] < 0) => !literal, for all words
* (3) (word == 0) => !literal
*
* Item (2) is why we can use objv to get the literals, and do not
* have to save them at compile time.
*/
for (word = 1; word < objc; word++) {
if (ePtr->line[word] >= 0) {
int isnew;
Tcl_HashEntry *hPtr =
Tcl_CreateHashEntry(iPtr->lineLABCPtr,
(char *) objv[word], &isnew);
CFWordBC *cfwPtr = (CFWordBC *) ckalloc(sizeof(CFWordBC));
cfwPtr->framePtr = cfPtr;
cfwPtr->obj = objv[word];
cfwPtr->pc = pc;
cfwPtr->word = word;
cfwPtr->nextPtr = lastPtr;
lastPtr = cfwPtr;
if (isnew) {
/*
* The word is not on the stack yet, remember the current
* location and initialize references.
*/
cfwPtr->prevPtr = NULL;
} else {
/*
* The object is already on the stack, however it may have
* a different location now (literal sharing may map
* multiple location to a single Tcl_Obj*. Save the old
* information in the new structure.
*/
cfwPtr->prevPtr = Tcl_GetHashValue(hPtr);
}
Tcl_SetHashValue(hPtr, cfwPtr);
}
} /* for */
cfPtr->litarg = lastPtr;
} /* if */
}
/*
*----------------------------------------------------------------------
*
* TclArgumentBCRelease --
|
| ︙ | ︙ | |||
5619 5620 5621 5622 5623 5624 5625 | * * TIP #280 *---------------------------------------------------------------------- */ void TclArgumentBCRelease( | | | | | | | | | < | 5623 5624 5625 5626 5627 5628 5629 5630 5631 5632 5633 5634 5635 5636 5637 5638 5639 5640 5641 5642 5643 5644 5645 5646 5647 5648 5649 5650 5651 5652 5653 5654 5655 5656 5657 5658 5659 |
*
* TIP #280
*----------------------------------------------------------------------
*/
void
TclArgumentBCRelease(
Tcl_Interp *interp,
CmdFrame *cfPtr)
{
Interp *iPtr = (Interp *) interp;
CFWordBC *cfwPtr = (CFWordBC *) cfPtr->litarg;
while (cfwPtr) {
CFWordBC *nextPtr = cfwPtr->nextPtr;
Tcl_HashEntry *hPtr =
Tcl_FindHashEntry(iPtr->lineLABCPtr, (char *) cfwPtr->obj);
CFWordBC *xPtr = Tcl_GetHashValue(hPtr);
if (xPtr != cfwPtr) {
Tcl_Panic ("TclArgumentBC Enter/Release Mismatch");
}
if (cfwPtr->prevPtr) {
Tcl_SetHashValue(hPtr, cfwPtr->prevPtr);
} else {
Tcl_DeleteHashEntry(hPtr);
}
ckfree((char *) cfwPtr);
cfwPtr = nextPtr;
}
cfPtr->litarg = NULL;
}
/*
|
| ︙ | ︙ | |||
6013 6014 6015 6016 6017 6018 6019 | * hashtable is managed in the file "tclObj.c". * * Another important action is to save (and later restore) the * continuation line information of the caller, in case we are * executing nested commands in the eval/direct path. */ | | | | 6016 6017 6018 6019 6020 6021 6022 6023 6024 6025 6026 6027 6028 6029 6030 6031 |
* hashtable is managed in the file "tclObj.c".
*
* Another important action is to save (and later restore) the
* continuation line information of the caller, in case we are
* executing nested commands in the eval/direct path.
*/
ContLineLoc *saveCLLocPtr = iPtr->scriptCLLocPtr;
ContLineLoc *clLocPtr = TclContinuationsGet (objPtr);
if (clLocPtr) {
iPtr->scriptCLLocPtr = clLocPtr;
Tcl_Preserve (iPtr->scriptCLLocPtr);
} else {
iPtr->scriptCLLocPtr = NULL;
}
|
| ︙ | ︙ | |||
7348 7349 7350 7351 7352 7353 7354 7355 7356 7357 7358 7359 7360 7361 7362 7363 7364 7365 7366 7367 7368 7369 7370 7371 7372 7373 7374 7375 7376 7377 7378 7379 7380 7381 7382 7383 7384 7385 7386 |
if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) {
return TCL_ERROR;
}
if (type == TCL_NUMBER_LONG) {
long l = *((const long *) ptr);
if (l <= (long)0) {
if (l == LONG_MIN) {
TclBNInitBignumFromLong(&big, l);
goto tooLarge;
}
Tcl_SetObjResult(interp, Tcl_NewLongObj(-l));
} else {
Tcl_SetObjResult(interp, objv[1]);
}
return TCL_OK;
}
if (type == TCL_NUMBER_DOUBLE) {
double d = *((const double *) ptr);
if (d <= 0.0) {
Tcl_SetObjResult(interp, Tcl_NewDoubleObj(-d));
} else {
Tcl_SetObjResult(interp, objv[1]);
}
return TCL_OK;
}
#ifndef NO_WIDE_TYPE
if (type == TCL_NUMBER_WIDE) {
Tcl_WideInt w = *((const Tcl_WideInt *) ptr);
if (w < (Tcl_WideInt)0) {
if (w == LLONG_MIN) {
TclBNInitBignumFromWideInt(&big, w);
goto tooLarge;
}
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(-w));
} else {
| > > > | 7351 7352 7353 7354 7355 7356 7357 7358 7359 7360 7361 7362 7363 7364 7365 7366 7367 7368 7369 7370 7371 7372 7373 7374 7375 7376 7377 7378 7379 7380 7381 7382 7383 7384 7385 7386 7387 7388 7389 7390 7391 7392 |
if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) {
return TCL_ERROR;
}
if (type == TCL_NUMBER_LONG) {
long l = *((const long *) ptr);
if (l <= (long)0) {
if (l == LONG_MIN) {
TclBNInitBignumFromLong(&big, l);
goto tooLarge;
}
Tcl_SetObjResult(interp, Tcl_NewLongObj(-l));
} else {
Tcl_SetObjResult(interp, objv[1]);
}
return TCL_OK;
}
if (type == TCL_NUMBER_DOUBLE) {
double d = *((const double *) ptr);
if (d <= 0.0) {
Tcl_SetObjResult(interp, Tcl_NewDoubleObj(-d));
} else {
Tcl_SetObjResult(interp, objv[1]);
}
return TCL_OK;
}
#ifndef NO_WIDE_TYPE
if (type == TCL_NUMBER_WIDE) {
Tcl_WideInt w = *((const Tcl_WideInt *) ptr);
if (w < (Tcl_WideInt)0) {
if (w == LLONG_MIN) {
TclBNInitBignumFromWideInt(&big, w);
goto tooLarge;
}
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(-w));
} else {
|
| ︙ | ︙ | |||
7405 7406 7407 7408 7409 7410 7411 7412 7413 7414 7415 7416 7417 7418 |
if (type == TCL_NUMBER_NAN) {
#ifdef ACCEPT_NAN
Tcl_SetObjResult(interp, objv[1]);
return TCL_OK;
#else
double d;
Tcl_GetDoubleFromObj(interp, objv[1], &d);
return TCL_ERROR;
#endif
}
return TCL_OK;
}
| > | 7411 7412 7413 7414 7415 7416 7417 7418 7419 7420 7421 7422 7423 7424 7425 |
if (type == TCL_NUMBER_NAN) {
#ifdef ACCEPT_NAN
Tcl_SetObjResult(interp, objv[1]);
return TCL_OK;
#else
double d;
Tcl_GetDoubleFromObj(interp, objv[1], &d);
return TCL_ERROR;
#endif
}
return TCL_OK;
}
|
| ︙ | ︙ | |||
7442 7443 7444 7445 7446 7447 7448 7449 7450 7451 7452 7453 7454 7455 |
ClientData clientData, /* Ignored. */
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
Tcl_Obj *const *objv) /* Actual parameter vector. */
{
double dResult;
if (objc != 2) {
MathFuncWrongNumArgs(interp, 2, objc, objv);
return TCL_ERROR;
}
if (Tcl_GetDoubleFromObj(interp, objv[1], &dResult) != TCL_OK) {
#ifdef ACCEPT_NAN
if (objv[1]->typePtr == &tclDoubleType) {
| > | 7449 7450 7451 7452 7453 7454 7455 7456 7457 7458 7459 7460 7461 7462 7463 |
ClientData clientData, /* Ignored. */
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
Tcl_Obj *const *objv) /* Actual parameter vector. */
{
double dResult;
if (objc != 2) {
MathFuncWrongNumArgs(interp, 2, objc, objv);
return TCL_ERROR;
}
if (Tcl_GetDoubleFromObj(interp, objv[1], &dResult) != TCL_OK) {
#ifdef ACCEPT_NAN
if (objv[1]->typePtr == &tclDoubleType) {
|
| ︙ | ︙ | |||
7557 7558 7559 7560 7561 7562 7563 7564 7565 7566 7567 7568 7569 7570 |
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
Tcl_Obj *const *objv) /* Actual parameter vector. */
{
Tcl_WideInt wResult;
Tcl_Obj *objPtr;
if (ExprEntierFunc(NULL, interp, objc, objv) != TCL_OK) {
return TCL_ERROR;
}
objPtr = Tcl_GetObjResult(interp);
if (Tcl_GetWideIntFromObj(NULL, objPtr, &wResult) != TCL_OK) {
/*
* Truncate the bignum; keep only bits in wide int range.
| > | 7565 7566 7567 7568 7569 7570 7571 7572 7573 7574 7575 7576 7577 7578 7579 |
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
Tcl_Obj *const *objv) /* Actual parameter vector. */
{
Tcl_WideInt wResult;
Tcl_Obj *objPtr;
if (ExprEntierFunc(NULL, interp, objc, objv) != TCL_OK) {
return TCL_ERROR;
}
objPtr = Tcl_GetObjResult(interp);
if (Tcl_GetWideIntFromObj(NULL, objPtr, &wResult) != TCL_OK) {
/*
* Truncate the bignum; keep only bits in wide int range.
|
| ︙ | ︙ | |||
8155 8156 8157 8158 8159 8160 8161 8162 8163 8164 8165 8166 8167 8168 8169 8170 |
* a proc, errors otherwise.
* (2) Should a tailcall bypass [catch] in the returning frame? Current
* implementation does not (or does it? Changed, test!) - it causes an
* error.
*
* FIXME NRE!
*/
int
TclNRTailcallObjCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Interp *iPtr = (Interp *) interp;
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < | 8164 8165 8166 8167 8168 8169 8170 8171 8172 8173 8174 8175 8176 8177 8178 8179 8180 8181 8182 8183 8184 8185 8186 8187 8188 8189 8190 8191 8192 8193 8194 8195 8196 8197 8198 8199 8200 8201 8202 8203 8204 8205 8206 8207 8208 8209 8210 8211 8212 8213 8214 8215 8216 8217 8218 8219 8220 8221 8222 8223 8224 8225 8226 8227 8228 8229 8230 8231 8232 8233 8234 8235 8236 |
* a proc, errors otherwise.
* (2) Should a tailcall bypass [catch] in the returning frame? Current
* implementation does not (or does it? Changed, test!) - it causes an
* error.
*
* FIXME NRE!
*/
void
TclSpliceTailcall (
Tcl_Interp *interp,
TEOV_callback *tailcallPtr)
{
/*
* Find the splicing spot: right before the NRCommand of the thing
* being tailcalled. Note that we skip NRCommands marked in data[1]
* (used by command redirectors)
*/
Interp *iPtr = (Interp *) interp;
TEOV_callback *runPtr;
ExecEnv *eePtr = NULL;
restart:
for (runPtr = TOP_CB(interp); runPtr; runPtr = runPtr->nextPtr) {
if (((runPtr->procPtr) == NRCommand) && !runPtr->data[1]) {
break;
}
}
if (!runPtr) {
/*
* If we are tailcalling out of a coroutine, the splicing spot is
* in the caller's execEnv: go find it!
*/
CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
if (corPtr) {
eePtr = iPtr->execEnvPtr;
iPtr->execEnvPtr = corPtr->callerEEPtr;
goto restart;
}
Tcl_Panic("Tailcall cannot find the right splicing spot: should not happen!");
}
tailcallPtr->nextPtr = runPtr->nextPtr;
runPtr->nextPtr = tailcallPtr;
if (eePtr) {
/*
* Restore the right execEnv if it was swapped for tailcalling out
* of a coroutine.
*/
iPtr->execEnvPtr = eePtr;
}
}
int
TclNRTailcallObjCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *listPtr, *nsObjPtr;
Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr;
Tcl_Namespace *ns1Ptr;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "command ?arg ...?");
return TCL_ERROR;
|
| ︙ | ︙ | |||
8212 8213 8214 8215 8216 8217 8218 |
*/
if (iPtr->cmdFramePtr->type == TCL_LOCATION_BC) {
TclArgumentBCRelease (interp, iPtr->cmdFramePtr);
}
TclNRAddCallback(interp, NRTailcallEval, listPtr, nsObjPtr, NULL, NULL);
| | | | > | | 8270 8271 8272 8273 8274 8275 8276 8277 8278 8279 8280 8281 8282 8283 8284 8285 8286 8287 8288 8289 8290 8291 8292 8293 8294 8295 8296 8297 8298 8299 8300 8301 8302 8303 8304 8305 |
*/
if (iPtr->cmdFramePtr->type == TCL_LOCATION_BC) {
TclArgumentBCRelease (interp, iPtr->cmdFramePtr);
}
TclNRAddCallback(interp, NRTailcallEval, listPtr, nsObjPtr, NULL, NULL);
iPtr->varFramePtr->tailcallPtr = TOP_CB(interp);
TOP_CB(interp) = TOP_CB(interp)->nextPtr;
TclNRAddCallback(interp, NRCallTEBC, INT2PTR(TCL_NR_TAILCALL_TYPE),
NULL, NULL, NULL);
return TCL_OK;
}
int
NRTailcallEval(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *listPtr = data[0];
Tcl_Obj *nsObjPtr = data[1];
Tcl_Namespace *nsPtr;
int objc;
Tcl_Obj **objv;
TclNRDeferCallback(interp, TailcallCleanup, listPtr, nsObjPtr, NULL,NULL);
if (result == TCL_OK) {
result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr);
if (result == TCL_OK) {
iPtr->lookupNsPtr = (Namespace *) nsPtr;
ListObjGetElements(listPtr, objc, objv);
result = TclNREvalObjv(interp, objc, objv, 0, NULL);
}
|
| ︙ | ︙ | |||
8329 8330 8331 8332 8333 8334 8335 |
(context).lineLABCPtr = iPtr->lineLABCPtr
#define RESTORE_CONTEXT(context) \
iPtr->framePtr = (context).framePtr; \
iPtr->varFramePtr = (context).varFramePtr; \
iPtr->cmdFramePtr = (context).cmdFramePtr; \
iPtr->lineLABCPtr = (context).lineLABCPtr
| | | > > > > > > > > > > > > > > > > > > > > > > > > > > > | 8388 8389 8390 8391 8392 8393 8394 8395 8396 8397 8398 8399 8400 8401 8402 8403 8404 8405 8406 8407 8408 8409 8410 8411 8412 8413 8414 8415 8416 8417 8418 8419 8420 8421 8422 8423 8424 8425 8426 8427 8428 8429 8430 8431 |
(context).lineLABCPtr = iPtr->lineLABCPtr
#define RESTORE_CONTEXT(context) \
iPtr->framePtr = (context).framePtr; \
iPtr->varFramePtr = (context).varFramePtr; \
iPtr->cmdFramePtr = (context).cmdFramePtr; \
iPtr->lineLABCPtr = (context).lineLABCPtr
#define iPtr ((Interp *) interp)
static int
YieldCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
CoroutineData *corPtr = data[0];
Tcl_Obj *listPtr = data[1];
corPtr->stackLevel = NULL; /* mark suspended */
iPtr->execEnvPtr = corPtr->callerEEPtr;
if (listPtr) {
/* yieldTo: invoke the command using tailcall tech */
TEOV_callback *cbPtr;
ClientData nsPtr = data[2];
TclNRAddCallback(interp, NRTailcallEval, listPtr, nsPtr,
NULL, NULL);
cbPtr = TOP_CB(interp);
TOP_CB(interp) = cbPtr->nextPtr;
TclSpliceTailcall(interp, cbPtr);
}
return TCL_OK;
}
int
TclNRYieldObjCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
|
| ︙ | ︙ | |||
8360 8361 8362 8363 8364 8365 8366 8367 8368 8369 8370 8371 8372 8373 8374 8375 8376 8377 |
if (objc == 2) {
Tcl_SetObjResult(interp, objv[1]);
}
iPtr->numLevels = corPtr->auxNumLevels;
corPtr->auxNumLevels = numLevels - corPtr->auxNumLevels;
TclNRAddCallback(interp, NRCallTEBC, INT2PTR(TCL_NR_YIELD_TYPE),
NULL, NULL, NULL);
return TCL_OK;
}
static int
RewindCoroutine(
CoroutineData *corPtr,
int result)
{
Tcl_Obj *objPtr;
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 8446 8447 8448 8449 8450 8451 8452 8453 8454 8455 8456 8457 8458 8459 8460 8461 8462 8463 8464 8465 8466 8467 8468 8469 8470 8471 8472 8473 8474 8475 8476 8477 8478 8479 8480 8481 8482 8483 8484 8485 8486 8487 8488 8489 8490 8491 8492 8493 8494 8495 8496 8497 8498 8499 8500 8501 8502 8503 8504 8505 8506 8507 8508 8509 8510 8511 8512 8513 |
if (objc == 2) {
Tcl_SetObjResult(interp, objv[1]);
}
iPtr->numLevels = corPtr->auxNumLevels;
corPtr->auxNumLevels = numLevels - corPtr->auxNumLevels;
TclNRAddCallback(interp, YieldCallback, corPtr, NULL, NULL, NULL);
TclNRAddCallback(interp, NRCallTEBC, INT2PTR(TCL_NR_YIELD_TYPE),
NULL, NULL, NULL);
return TCL_OK;
}
int
TclNRYieldToObjCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
int numLevels = iPtr->numLevels;
Tcl_Obj *listPtr, *nsObjPtr;
Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr;
Tcl_Namespace *ns1Ptr;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "command ?arg ...?");
return TCL_ERROR;
}
if (!corPtr) {
Tcl_SetResult(interp, "yieldTo can only be called in a coroutine",
TCL_STATIC);
return TCL_ERROR;
}
iPtr->numLevels = corPtr->auxNumLevels;
corPtr->auxNumLevels = numLevels - corPtr->auxNumLevels;
/*
* This is essentially code from TclNRTailcallObjCmd
*/
listPtr = Tcl_NewListObj(objc-1, objv+1);
Tcl_IncrRefCount(listPtr);
nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1);
if ((TCL_OK != TclGetNamespaceFromObj(interp, nsObjPtr, &ns1Ptr))
|| (nsPtr != ns1Ptr)) {
Tcl_Panic("yieldTo failed to find the proper namespace");
}
Tcl_IncrRefCount(nsObjPtr);
TclNRAddCallback(interp, YieldCallback, corPtr, listPtr, nsObjPtr, NULL);
TclNRAddCallback(interp, NRCallTEBC, INT2PTR(TCL_NR_YIELD_TYPE),
NULL, NULL, NULL);
return TCL_OK;
}
static int
RewindCoroutine(
CoroutineData *corPtr,
int result)
{
Tcl_Obj *objPtr;
|
| ︙ | ︙ | |||
8566 8567 8568 8569 8570 8571 8572 |
return TCL_ERROR;
}
if (!COR_IS_SUSPENDED(corPtr)) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "coroutine \"", Tcl_GetString(objv[0]),
"\" is already running", NULL);
| | | | | | 8702 8703 8704 8705 8706 8707 8708 8709 8710 8711 8712 8713 8714 8715 8716 8717 8718 8719 8720 8721 8722 8723 |
return TCL_ERROR;
}
if (!COR_IS_SUSPENDED(corPtr)) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "coroutine \"", Tcl_GetString(objv[0]),
"\" is already running", NULL);
Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "BUSY", NULL);
return TCL_ERROR;
}
/*
* Swap the interp's environment to make it suitable to run this
* coroutine. TEBC needs no info to resume executing after a suspension:
* the codePtr will be read from the execEnv's saved bottomPtr.
*/
if (objc == 2) {
Tcl_SetObjResult(interp, objv[1]);
}
SAVE_CONTEXT(corPtr->caller);
|
| ︙ | ︙ | |||
8610 8611 8612 8613 8614 8615 8616 8617 8618 8619 8620 8621 8622 8623 |
Tcl_Obj *cmdObjPtr;
CallFrame *framePtr, **framePtrPtr;
TEOV_callback *rootPtr = TOP_CB(interp);
const char *fullName;
const char *procName;
Namespace *nsPtr, *altNsPtr, *cxtNsPtr;
Tcl_DString ds;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "name cmd ?arg ...?");
return TCL_ERROR;
}
/*
| > | 8746 8747 8748 8749 8750 8751 8752 8753 8754 8755 8756 8757 8758 8759 8760 |
Tcl_Obj *cmdObjPtr;
CallFrame *framePtr, **framePtrPtr;
TEOV_callback *rootPtr = TOP_CB(interp);
const char *fullName;
const char *procName;
Namespace *nsPtr, *altNsPtr, *cxtNsPtr;
Tcl_DString ds;
int result;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "name cmd ?arg ...?");
return TCL_ERROR;
}
/*
|
| ︙ | ︙ | |||
8717 8718 8719 8720 8721 8722 8723 |
* CFWordBC chains are not duplicated, only the entrypoints to them. This
* means that in the presence of coroutines each chain is potentially a
* tree. Like the chain -> tree conversion of the CmdFrame stack.
*/
{
Tcl_HashSearch hSearch;
| | | > < | | | | > | 8854 8855 8856 8857 8858 8859 8860 8861 8862 8863 8864 8865 8866 8867 8868 8869 8870 8871 8872 8873 8874 8875 8876 8877 8878 8879 8880 8881 |
* CFWordBC chains are not duplicated, only the entrypoints to them. This
* means that in the presence of coroutines each chain is potentially a
* tree. Like the chain -> tree conversion of the CmdFrame stack.
*/
{
Tcl_HashSearch hSearch;
Tcl_HashEntry *hePtr;
corPtr->base.lineLABCPtr = (Tcl_HashTable *)
ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(corPtr->base.lineLABCPtr, TCL_ONE_WORD_KEYS);
for (hePtr = Tcl_FirstHashEntry(iPtr->lineLABCPtr,&hSearch);
hePtr; hePtr = Tcl_NextHashEntry(&hSearch)) {
int isNew;
Tcl_HashEntry *newPtr =
Tcl_CreateHashEntry(corPtr->base.lineLABCPtr,
(char *) Tcl_GetHashKey(iPtr->lineLABCPtr, hePtr),
&isNew);
Tcl_SetHashValue(newPtr, Tcl_GetHashValue(hePtr));
}
/*
* The new copy is immediately plugged interpreter for use by the
* first coroutine commands (see below). The interp's copy of the
* table is already saved, see the SAVE_CONTEXT found just above this
|
| ︙ | ︙ | |||
8759 8760 8761 8762 8763 8764 8765 |
*/
iPtr->varFramePtr = iPtr->rootFramePtr;
iPtr->lookupNsPtr = iPtr->framePtr->nsPtr;
corPtr->auxNumLevels = iPtr->numLevels;
TclNRAddCallback(interp, NRCoroutineExitCallback, corPtr, NULL,NULL,NULL);
| | > | > > | 8897 8898 8899 8900 8901 8902 8903 8904 8905 8906 8907 8908 8909 8910 8911 8912 8913 8914 8915 |
*/
iPtr->varFramePtr = iPtr->rootFramePtr;
iPtr->lookupNsPtr = iPtr->framePtr->nsPtr;
corPtr->auxNumLevels = iPtr->numLevels;
TclNRAddCallback(interp, NRCoroutineExitCallback, corPtr, NULL,NULL,NULL);
iPtr->evalFlags |= TCL_EVAL_REDIRECT;
result = TclNREvalObjEx(interp, cmdObjPtr, 0, NULL, 0);
return TclNRRunCallbacks(interp, result, rootPtr, 0);
}
/*
* This is used in the [info] ensemble
*/
int
|
| ︙ | ︙ |
Changes to generic/tclCmdIL.c.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 | * Copyright (c) 1998-1999 by Scriptics Corporation. * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. * Copyright (c) 2005 Donal K. Fellows. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 | * Copyright (c) 1998-1999 by Scriptics Corporation. * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. * Copyright (c) 2005 Donal K. Fellows. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclCmdIL.c,v 1.50.2.61 2009/12/08 18:39:19 dgp Exp $ */ #include "tclInt.h" #include "tclRegexp.h" /* * During execution of the "lsort" command, structures of the following type |
| ︙ | ︙ | |||
1096 1097 1098 1099 1100 1101 1102 |
if (iPtr->execEnvPtr->corPtr) {
/*
* A coroutine: must fix the level computations
*/
| | | 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 |
if (iPtr->execEnvPtr->corPtr) {
/*
* A coroutine: must fix the level computations
*/
topLevel += iPtr->execEnvPtr->corPtr->caller.cmdFramePtr->level -
iPtr->execEnvPtr->corPtr->base.cmdFramePtr->level;
}
if (objc == 1) {
/*
* Just "info frame".
*/
|
| ︙ | ︙ |
Changes to generic/tclCmdMZ.c.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 | * Copyright (c) 1998-2000 Scriptics Corporation. * Copyright (c) 2002 ActiveState Corporation. * Copyright (c) 2003 Donal K. Fellows. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 | * Copyright (c) 1998-2000 Scriptics Corporation. * Copyright (c) 2002 ActiveState Corporation. * Copyright (c) 2003 Donal K. Fellows. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclCmdMZ.c,v 1.90.2.68 2009/12/08 18:39:19 dgp Exp $ */ #include "tclInt.h" #include "tclRegexp.h" static inline Tcl_Obj * During(Tcl_Interp *interp, int resultCode, Tcl_Obj *oldOptions, Tcl_Obj *errorInfo); |
| ︙ | ︙ | |||
4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 4447 4448 4449 4450 4451 |
Tcl_ListObjLength(NULL, info[3], &dummy);
if (dummy > 0) {
Tcl_Obj *varName;
Tcl_ListObjIndex(NULL, info[3], 0, &varName);
if (Tcl_ObjSetVar2(interp, varName, NULL, resultObj,
TCL_LEAVE_ERR_MSG) == NULL) {
goto handlerFailed;
}
if (dummy > 1) {
Tcl_ListObjIndex(NULL, info[3], 1, &varName);
if (Tcl_ObjSetVar2(interp, varName, NULL, options,
TCL_LEAVE_ERR_MSG) == NULL) {
goto handlerFailed;
}
}
}
/*
* Evaluate the handler body and process the outcome. Note that we
* need to keep the kind of handler for debugging purposes, and in
* any case anything we want from info[] must be extracted right
* now because the info[] array is about to become invalid. There
| > > > > > > > > | 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 4447 4448 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 |
Tcl_ListObjLength(NULL, info[3], &dummy);
if (dummy > 0) {
Tcl_Obj *varName;
Tcl_ListObjIndex(NULL, info[3], 0, &varName);
if (Tcl_ObjSetVar2(interp, varName, NULL, resultObj,
TCL_LEAVE_ERR_MSG) == NULL) {
Tcl_DecrRefCount(resultObj);
goto handlerFailed;
}
Tcl_DecrRefCount(resultObj);
if (dummy > 1) {
Tcl_ListObjIndex(NULL, info[3], 1, &varName);
if (Tcl_ObjSetVar2(interp, varName, NULL, options,
TCL_LEAVE_ERR_MSG) == NULL) {
goto handlerFailed;
}
}
} else {
/*
* Dispose of the result to prevent a memleak. [Bug 2910044]
*/
Tcl_DecrRefCount(resultObj);
}
/*
* Evaluate the handler body and process the outcome. Note that we
* need to keep the kind of handler for debugging purposes, and in
* any case anything we want from info[] must be extracted right
* now because the info[] array is about to become invalid. There
|
| ︙ | ︙ |
Changes to generic/tclExecute.c.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 | * Copyright (c) 2005-2007 by Donal K. Fellows. * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net> * Copyright (c) 2006-2008 by Joe Mistachkin. All rights reserved. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | * Copyright (c) 2005-2007 by Donal K. Fellows. * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net> * Copyright (c) 2006-2008 by Joe Mistachkin. 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: tclExecute.c,v 1.101.2.125 2009/12/08 18:39:19 dgp Exp $ */ #include "tclInt.h" #include "tclCompile.h" #include "tommath.h" #include <math.h> |
| ︙ | ︙ | |||
161 162 163 164 165 166 167 |
{"srand", 1},
{"wide", 1},
{NULL, 0},
};
#define LAST_BUILTIN_FUNC 25
#endif
| | | > | | | | | | | > | | | > | > | < | < | > | > | | < | < | | > | > | | > | | | | | 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 |
{"srand", 1},
{"wide", 1},
{NULL, 0},
};
#define LAST_BUILTIN_FUNC 25
#endif
/*
* NR_TEBC
* Helpers for NR - non-recursive calls to TEBC
* Minimal data required to fully reconstruct the execution state.
*/
typedef struct BottomData {
struct BottomData *prevBottomPtr;
TEOV_callback *rootPtr; /* State when this bytecode execution
* began: */
ByteCode *codePtr; /* constant until it returns */
/* -----------------------------------------*/
const unsigned char *pc; /* These fields are used on return TO this */
ptrdiff_t *catchTop; /* this level: they record the state when a */
int cleanup; /* new codePtr was received for NR */
Tcl_Obj *auxObjList; /* execution. */
} BottomData;
#define NR_DATA_INIT() \
do { \
BP->prevBottomPtr = OBP; \
BP->rootPtr = TOP_CB(iPtr); \
BP->codePtr = codePtr; \
} while (0)
#define NR_DATA_BURY() \
do { \
BP->pc = pc; \
BP->cleanup = cleanup; \
OBP = BP; \
} while (0)
#define NR_DATA_DIG() \
do { \
pc = BP->pc; \
codePtr = BP->codePtr; \
cleanup = BP->cleanup; \
TAUX.esPtr = iPtr->execEnvPtr->execStackPtr; \
tosPtr = TAUX.esPtr->tosPtr; \
} while (0)
#define PUSH_TAUX_OBJ(objPtr) \
do { \
objPtr->internalRep.twoPtrValue.ptr2 = auxObjList; \
auxObjList = objPtr; \
} while (0)
#define POP_TAUX_OBJ() \
do { \
Tcl_Obj *tmpPtr = auxObjList; \
auxObjList = (Tcl_Obj *) tmpPtr->internalRep.twoPtrValue.ptr2; \
Tcl_DecrRefCount(tmpPtr); \
} while (0)
/*
* These variable-access macros have to coincide with those in tclVar.c
*/
#define VarHashGetValue(hPtr) \
((Var *) ((char *)hPtr - TclOffset(VarInHash, entry)))
|
| ︙ | ︙ | |||
235 236 237 238 239 240 241 |
return NULL;
}
return VarHashGetValue(hPtr);
}
#define VarHashFindVar(tablePtr, key) \
VarHashCreateVar((tablePtr), (key), NULL)
| | > | | | | | | | | | | | | | | | | | | | | | | | | | | | > > | | | | | | | | | | > | > | | > | 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 |
return NULL;
}
return VarHashGetValue(hPtr);
}
#define VarHashFindVar(tablePtr, key) \
VarHashCreateVar((tablePtr), (key), NULL)
/*
* The new macro for ending an instruction; note that a reasonable C-optimiser
* will resolve all branches at compile time. (result) is always a constant;
* the macro NEXT_INST_F handles constant (nCleanup), NEXT_INST_V is resolved
* at runtime for variable (nCleanup).
*
* ARGUMENTS:
* pcAdjustment: how much to increment pc
* nCleanup: how many objects to remove from the stack
* resultHandling: 0 indicates no object should be pushed on the stack;
* otherwise, push objResultPtr. If (result < 0), objResultPtr already
* has the correct reference count.
*
* We use the new compile-time assertions to cheack that nCleanup is constant
* and within range.
*/
#define NEXT_INST_F(pcAdjustment, nCleanup, resultHandling) \
do { \
TCL_CT_ASSERT((nCleanup >= 0) && (nCleanup <= 2)); \
if (nCleanup == 0) { \
if (resultHandling != 0) { \
if ((resultHandling) > 0) { \
PUSH_OBJECT(objResultPtr); \
} else { \
*(++tosPtr) = objResultPtr; \
} \
} \
pc += (pcAdjustment); \
goto cleanup0; \
} else if (resultHandling != 0) { \
if ((resultHandling) > 0) { \
Tcl_IncrRefCount(objResultPtr); \
} \
pc += (pcAdjustment); \
switch (nCleanup) { \
case 1: goto cleanup1_pushObjResultPtr; \
case 2: goto cleanup2_pushObjResultPtr; \
} \
} else { \
pc += (pcAdjustment); \
switch (nCleanup) { \
case 1: goto cleanup1; \
case 2: goto cleanup2; \
} \
} \
} while (0)
#define NEXT_INST_V(pcAdjustment, nCleanup, resultHandling) \
do { \
pc += (pcAdjustment); \
cleanup = (nCleanup); \
if (resultHandling) { \
if ((resultHandling) > 0) { \
Tcl_IncrRefCount(objResultPtr); \
} \
goto cleanupV_pushObjResultPtr; \
} else { \
goto cleanupV; \
} \
} while (0)
/*
* Macros used to cache often-referenced Tcl evaluation stack information
* in local variables. Note that a DECACHE_STACK_INFO()-CACHE_STACK_INFO()
* pair must surround any call inside TclExecuteByteCode (and a few other
* procedures that use this scheme) that could result in a recursive call
* to TclExecuteByteCode.
*/
#define CACHE_STACK_INFO() \
TAUX.checkInterp = 1
#define DECACHE_STACK_INFO() \
do { \
TAUX.esPtr->tosPtr = tosPtr; \
iPtr->execEnvPtr->bottomPtr = BP; \
} while (0)
/*
* Macros used to access items on the Tcl evaluation stack. PUSH_OBJECT
* increments the object's ref count since it makes the stack have another
* reference pointing to the object. However, POP_OBJECT does not decrement
* the ref count. This is because the stack may hold the only reference to the
* object, so the object would be destroyed if its ref count were decremented
|
| ︙ | ︙ | |||
345 346 347 348 349 350 351 | * Macros used to trace instruction execution. The macros TRACE, * TRACE_WITH_OBJ, and O2S are only used inside TclExecuteByteCode. O2S is * only used in TRACE* calls to get a string from an object. */ #ifdef TCL_COMPILE_DEBUG # define TRACE(a) \ | | | | | | | > | | > | | | | | | | | > > | | | | | | | | | | | | | | > > | | | > | < | | < < | < | | | | | | 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 |
* Macros used to trace instruction execution. The macros TRACE,
* TRACE_WITH_OBJ, and O2S are only used inside TclExecuteByteCode. O2S is
* only used in TRACE* calls to get a string from an object.
*/
#ifdef TCL_COMPILE_DEBUG
# define TRACE(a) \
while (traceInstructions) { \
fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, \
(int) CURR_DEPTH, \
(unsigned) (pc - codePtr->codeStart), \
GetOpcodeName(pc)); \
printf a; \
break; \
}
# define TRACE_APPEND(a) \
while (traceInstructions) { \
printf a; \
break; \
}
# define TRACE_WITH_OBJ(a, objPtr) \
while (traceInstructions) { \
fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, \
(int) CURR_DEPTH, \
(unsigned) (pc - codePtr->codeStart), \
GetOpcodeName(pc)); \
printf a; \
TclPrintObject(stdout, objPtr, 30); \
fprintf(stdout, "\n"); \
break; \
}
# define O2S(objPtr) \
(objPtr ? TclGetString(objPtr) : "")
#else /* !TCL_COMPILE_DEBUG */
# define TRACE(a)
# define TRACE_APPEND(a)
# define TRACE_WITH_OBJ(a, objPtr)
# define O2S(objPtr)
#endif /* TCL_COMPILE_DEBUG */
/*
* DTrace instruction probe macros.
*/
#define TCL_DTRACE_INST_NEXT() \
do { \
if (TCL_DTRACE_INST_DONE_ENABLED()) { \
if (TAUX.curInstName) { \
TCL_DTRACE_INST_DONE(TAUX.curInstName, (int) CURR_DEPTH, \
tosPtr); \
} \
TAUX.curInstName = tclInstructionTable[*pc].name; \
if (TCL_DTRACE_INST_START_ENABLED()) { \
TCL_DTRACE_INST_START(TAUX.curInstName, (int) CURR_DEPTH, \
tosPtr); \
} \
} else if (TCL_DTRACE_INST_START_ENABLED()) { \
TCL_DTRACE_INST_START(tclInstructionTable[*pc].name, \
(int) CURR_DEPTH, tosPtr); \
} \
} while (0)
#define TCL_DTRACE_INST_LAST() \
do { \
if (TCL_DTRACE_INST_DONE_ENABLED() && TAUX.curInstName) { \
TCL_DTRACE_INST_DONE(TAUX.curInstName, (int) CURR_DEPTH, tosPtr);\
} \
} while (0)
/*
* Macro used in this file to save a function call for common uses of
* TclGetNumberFromObj(). The ANSI C "prototype" is:
*
* MODULE_SCOPE int GetNumberFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
* ClientData *ptrPtr, int *tPtr);
*/
#ifdef NO_WIDE_TYPE
#define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \
(((objPtr)->typePtr == &tclIntType) \
? (*(tPtr) = TCL_NUMBER_LONG, \
*(ptrPtr) = (ClientData) \
(&((objPtr)->internalRep.longValue)), TCL_OK) : \
((objPtr)->typePtr == &tclDoubleType) \
? (((TclIsNaN((objPtr)->internalRep.doubleValue)) \
? (*(tPtr) = TCL_NUMBER_NAN) \
: (*(tPtr) = TCL_NUMBER_DOUBLE)), \
*(ptrPtr) = (ClientData) \
(&((objPtr)->internalRep.doubleValue)), TCL_OK) : \
((((objPtr)->typePtr == NULL) && ((objPtr)->bytes == NULL)) || \
(((objPtr)->bytes != NULL) && ((objPtr)->length == 0))) \
? TCL_ERROR : \
TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr)))
#else /* !NO_WIDE_TYPE */
#define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \
(((objPtr)->typePtr == &tclIntType) \
? (*(tPtr) = TCL_NUMBER_LONG, \
*(ptrPtr) = (ClientData) \
(&((objPtr)->internalRep.longValue)), TCL_OK) : \
((objPtr)->typePtr == &tclWideIntType) \
? (*(tPtr) = TCL_NUMBER_WIDE, \
*(ptrPtr) = (ClientData) \
(&((objPtr)->internalRep.wideValue)), TCL_OK) : \
((objPtr)->typePtr == &tclDoubleType) \
? (((TclIsNaN((objPtr)->internalRep.doubleValue)) \
? (*(tPtr) = TCL_NUMBER_NAN) \
: (*(tPtr) = TCL_NUMBER_DOUBLE)), \
*(ptrPtr) = (ClientData) \
(&((objPtr)->internalRep.doubleValue)), TCL_OK) : \
((((objPtr)->typePtr == NULL) && ((objPtr)->bytes == NULL)) || \
(((objPtr)->bytes != NULL) && ((objPtr)->length == 0))) \
? TCL_ERROR : \
TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr)))
#endif /* NO_WIDE_TYPE */
/*
* Macro used in this file to save a function call for common uses of
* Tcl_GetBooleanFromObj(). The ANSI C "prototype" is:
*
* MODULE_SCOPE int TclGetBooleanFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
* int *boolPtr);
*/
#define TclGetBooleanFromObj(interp, objPtr, boolPtr) \
((((objPtr)->typePtr == &tclIntType) \
|| ((objPtr)->typePtr == &tclBooleanType)) \
? (*(boolPtr) = ((objPtr)->internalRep.longValue!=0), TCL_OK) \
: Tcl_GetBooleanFromObj((interp), (objPtr), (boolPtr)))
/*
* Macro used in this file to save a function call for common uses of
* Tcl_GetWideIntFromObj(). The ANSI C "prototype" is:
*
* MODULE_SCOPE int TclGetWideIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
* Tcl_WideInt *wideIntPtr);
*/
#ifdef NO_WIDE_TYPE
#define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \
(((objPtr)->typePtr == &tclIntType) \
? (*(wideIntPtr) = (Tcl_WideInt) \
((objPtr)->internalRep.longValue), TCL_OK) : \
Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr)))
#else /* !NO_WIDE_TYPE */
#define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \
(((objPtr)->typePtr == &tclWideIntType) \
? (*(wideIntPtr) = (objPtr)->internalRep.wideValue, TCL_OK) : \
((objPtr)->typePtr == &tclIntType) \
? (*(wideIntPtr) = (Tcl_WideInt) \
((objPtr)->internalRep.longValue), TCL_OK) : \
Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr)))
#endif /* NO_WIDE_TYPE */
/*
* Macro used to make the check for type overflow more mnemonic. This works by
* comparing sign bits; the rest of the word is irrelevant. The ANSI C
* "prototype" (where inttype_t is any integer type) is:
*
* MODULE_SCOPE int Overflowing(inttype_t a, inttype_t b, inttype_t sum);
|
| ︙ | ︙ | |||
509 510 511 512 513 514 515 |
* be seen by user scripts.
*/
static const Tcl_ObjType dictIteratorType = {
"dictIterator",
NULL, NULL, NULL, NULL
};
| | | | | > < | | > | 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 |
* be seen by user scripts.
*/
static const Tcl_ObjType dictIteratorType = {
"dictIterator",
NULL, NULL, NULL, NULL
};
/*
* Auxiliary tables used to compute powers of small integers.
*/
#if (LONG_MAX == 0x7fffffff)
/*
* Maximum base that, when raised to powers 2, 3, ... 8, fits in a 32-bit
* signed integer.
*/
static const long MaxBase32[] = {46340, 1290, 215, 73, 35, 21, 14};
static const size_t MaxBase32Size = sizeof(MaxBase32)/sizeof(long);
/*
* Table giving 3, 4, ..., 11, raised to the powers 9, 10, ..., as far as they
* fit in a 32-bit signed integer. Exp32Index[i] gives the starting index of
* powers of i+3; Exp32Value[i] gives the corresponding powers.
*/
static const unsigned short Exp32Index[] = {
0, 11, 18, 23, 26, 29, 31, 32, 33
};
static const size_t Exp32IndexSize =
sizeof(Exp32Index) / sizeof(unsigned short);
static const long Exp32Value[] = {
19683, 59049, 177147, 531441, 1594323, 4782969, 14348907, 43046721,
129140163, 387420489, 1162261467, 262144, 1048576, 4194304,
16777216, 67108864, 268435456, 1073741824, 1953125, 9765625,
48828125, 244140625, 1220703125, 10077696, 60466176, 362797056,
40353607, 282475249, 1977326743, 134217728, 1073741824, 387420489,
1000000000
};
static const size_t Exp32ValueSize = sizeof(Exp32Value)/sizeof(long);
#endif /* LONG_MAX == 0x7fffffff -- 32 bit machine */
#if (LONG_MAX > 0x7fffffff) || !defined(TCL_WIDE_INT_IS_LONG)
/*
* Maximum base that, when raised to powers 2, 3, ..., 16, fits in a
* Tcl_WideInt.
*/
static const Tcl_WideInt MaxBase64[] = {
(Tcl_WideInt)46340*65536+62259, /* 3037000499 == isqrt(2**63-1) */
(Tcl_WideInt)2097151, (Tcl_WideInt)55108, (Tcl_WideInt)6208,
(Tcl_WideInt)1448, (Tcl_WideInt)511, (Tcl_WideInt)234, (Tcl_WideInt)127,
(Tcl_WideInt)78, (Tcl_WideInt)52, (Tcl_WideInt)38, (Tcl_WideInt)28,
(Tcl_WideInt)22, (Tcl_WideInt)18, (Tcl_WideInt)15
};
static const size_t MaxBase64Size = sizeof(MaxBase64)/sizeof(Tcl_WideInt);
/*
* Table giving 3, 4, ..., 13 raised to powers greater than 16 when the
* results fit in a 64-bit signed integer.
*/
static const unsigned short Exp64Index[] = {
0, 23, 38, 49, 57, 63, 67, 70, 72, 74, 75, 76
};
static const size_t Exp64IndexSize =
sizeof(Exp64Index) / sizeof(unsigned short);
static const Tcl_WideInt Exp64Value[] = {
(Tcl_WideInt)243*243*243*3*3,
(Tcl_WideInt)243*243*243*3*3*3,
(Tcl_WideInt)243*243*243*3*3*3*3,
(Tcl_WideInt)243*243*243*243,
(Tcl_WideInt)243*243*243*243*3,
(Tcl_WideInt)243*243*243*243*3*3,
|
| ︙ | ︙ | |||
649 650 651 652 653 654 655 |
(Tcl_WideInt)100000*100000*100000*10*10,
(Tcl_WideInt)100000*100000*100000*10*10*10,
(Tcl_WideInt)161051*161051*161051*11*11,
(Tcl_WideInt)161051*161051*161051*11*11*11,
(Tcl_WideInt)248832*248832*248832*12*12,
(Tcl_WideInt)371293*371293*371293*13*13
};
| | | < | | 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 |
(Tcl_WideInt)100000*100000*100000*10*10,
(Tcl_WideInt)100000*100000*100000*10*10*10,
(Tcl_WideInt)161051*161051*161051*11*11,
(Tcl_WideInt)161051*161051*161051*11*11*11,
(Tcl_WideInt)248832*248832*248832*12*12,
(Tcl_WideInt)371293*371293*371293*13*13
};
static const size_t Exp64ValueSize = sizeof(Exp64Value) / sizeof(Tcl_WideInt);
#endif /* (LONG_MAX > 0x7fffffff) || !defined(TCL_WIDE_INT_IS_LONG) */
/*
* Declarations for local procedures to this file:
*/
#ifdef TCL_COMPILE_STATS
static int EvalStatsCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
|
| ︙ | ︙ | |||
675 676 677 678 679 680 681 | int stackLowerBound, int checkStack); #endif /* TCL_COMPILE_DEBUG */ static ByteCode * CompileExprObj(Tcl_Interp *interp, Tcl_Obj *objPtr); static void DeleteExecStack(ExecStack *esPtr); static void DupExprCodeInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); static void FreeExprCodeInternalRep(Tcl_Obj *objPtr); | | | | | < | 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 | int stackLowerBound, int checkStack); #endif /* TCL_COMPILE_DEBUG */ static ByteCode * CompileExprObj(Tcl_Interp *interp, Tcl_Obj *objPtr); static void DeleteExecStack(ExecStack *esPtr); static void DupExprCodeInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); static void FreeExprCodeInternalRep(Tcl_Obj *objPtr); static ExceptionRange * GetExceptRangeForPc(const unsigned char *pc, int catchOnly, ByteCode *codePtr); static const char * GetSrcInfoForPc(const unsigned char *pc, ByteCode *codePtr, int *lengthPtr); static Tcl_Obj ** GrowEvaluationStack(ExecEnv *eePtr, int growth, int move); static void IllegalExprOperandType(Tcl_Interp *interp, const unsigned char *pc, Tcl_Obj *opndPtr); static void InitByteCodeExecution(Tcl_Interp *interp); static inline int OFFSET(void *ptr); /* Useful elsewhere, make available in tclInt.h or stubs? */ static Tcl_Obj ** StackAllocWords(Tcl_Interp *interp, int numWords); static Tcl_Obj ** StackReallocWords(Tcl_Interp *interp, int numWords); static Tcl_NRPostProc CopyCallback; static Tcl_NRPostProc ExprObjCallback; /* * The structure below defines a bytecode Tcl object type to hold the * compiled bytecode for Tcl expressions. */ |
| ︙ | ︙ | |||
769 770 771 772 773 774 775 |
*----------------------------------------------------------------------
*/
ExecEnv *
TclCreateExecEnv(
Tcl_Interp *interp, /* Interpreter for which the execution
* environment is being created. */
| | | 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 |
*----------------------------------------------------------------------
*/
ExecEnv *
TclCreateExecEnv(
Tcl_Interp *interp, /* Interpreter for which the execution
* environment is being created. */
int size) /* The initial stack size, in number of words
* [sizeof(Tcl_Obj*)] */
{
ExecEnv *eePtr = (ExecEnv *) ckalloc(sizeof(ExecEnv));
ExecStack *esPtr = (ExecStack *) ckalloc(sizeof(ExecStack)
+ (size_t) (size-1) * sizeof(Tcl_Obj *));
eePtr->execStackPtr = esPtr;
|
| ︙ | ︙ | |||
926 927 928 929 930 931 932 |
return (TCL_ALLOCALIGN - base)/sizeof(Tcl_Obj *);
}
/*
* Given a marker, compute where the following aligned memory starts.
*/
| | < | 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 |
return (TCL_ALLOCALIGN - base)/sizeof(Tcl_Obj *);
}
/*
* Given a marker, compute where the following aligned memory starts.
*/
#define MEMSTART(markerPtr) \
((markerPtr) + OFFSET(markerPtr))
/*
*----------------------------------------------------------------------
*
* GrowEvaluationStack --
*
* This procedure grows a Tcl evaluation stack stored in an ExecEnv,
|
| ︙ | ︙ | |||
1444 1445 1446 1447 1448 1449 1450 | /* *---------------------------------------------------------------------- * * DupExprCodeInternalRep -- * * Part of the Tcl object type implementation for Tcl expression | | | | | | | | | | | | 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 | /* *---------------------------------------------------------------------- * * DupExprCodeInternalRep -- * * Part of the Tcl object type implementation for Tcl expression * bytecode. We do not copy the bytecode intrep. Instead, we return * without setting copyPtr->typePtr, so the copy is a plain string copy * of the expression value, and if it is to be used as a compiled * expression, it will just need a recompile. * * This makes sense, because with Tcl's copy-on-write practices, the * usual (only?) time Tcl_DuplicateObj() will be called is when the copy * is about to be modified, which would invalidate any copied bytecode * anyway. The only reason it might make sense to copy the bytecode is if * we had some modifying routines that operated directly on the intrep, * like we do for lists and dicts. * * Results: * None. * * Side effects: * None. * |
| ︙ | ︙ | |||
1479 1480 1481 1482 1483 1484 1485 | /* *---------------------------------------------------------------------- * * FreeExprCodeInternalRep -- * * Part of the Tcl object type implementation for Tcl expression | | | | > | 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 |
/*
*----------------------------------------------------------------------
*
* FreeExprCodeInternalRep --
*
* Part of the Tcl object type implementation for Tcl expression
* bytecode. Frees the storage allocated to hold the internal rep, unless
* ref counts indicate bytecode execution is still in progress.
*
* Results:
* None.
*
* Side effects:
* May free allocated memory. Leaves objPtr untyped.
*
*----------------------------------------------------------------------
*/
static void
FreeExprCodeInternalRep(
Tcl_Obj *objPtr)
{
|
| ︙ | ︙ | |||
1611 1612 1613 1614 1615 1616 1617 |
* the users to adjust the locations they have by this offset.
*
* (3) Alternative 2: Do not fully recompile, adjust just the location
* information.
*/
{
| | | > | < | | > > | | | | | < | | | 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 |
* the users to adjust the locations they have by this offset.
*
* (3) Alternative 2: Do not fully recompile, adjust just the location
* information.
*/
{
Tcl_HashEntry *hePtr =
Tcl_FindHashEntry(iPtr->lineBCPtr, (char *) codePtr);
if (hePtr) {
ExtCmdLoc *eclPtr = Tcl_GetHashValue(hePtr);
int redo = 0;
if (invoker) {
CmdFrame *ctxPtr = TclStackAlloc(interp,sizeof(CmdFrame));
*ctxPtr = *invoker;
if (invoker->type == TCL_LOCATION_BC) {
/*
* Note: Type BC => ctx.data.eval.path is not used.
* ctx.data.tebc.codePtr used instead
*/
TclGetSrcInfoForPc(ctxPtr);
if (ctxPtr->type == TCL_LOCATION_SOURCE) {
/*
* The reference made by 'TclGetSrcInfoForPc' is
* dead.
*/
Tcl_DecrRefCount(ctxPtr->data.eval.path);
ctxPtr->data.eval.path = NULL;
}
}
if (word < ctxPtr->nline) {
/*
* Note: We do not care if the line[word] is -1. This
* is a difference and requires a recompile (location
* changed from absolute to relative, literal is used
* fixed and through variable)
*
* Example:
* test info-32.0 using literal of info-24.8
* (dict with ... vs set body ...).
*/
redo = ((eclPtr->type == TCL_LOCATION_SOURCE)
&& (eclPtr->start != ctxPtr->line[word]))
|| ((eclPtr->type == TCL_LOCATION_BC)
&& (ctxPtr->type == TCL_LOCATION_SOURCE));
}
TclStackFree(interp, ctxPtr);
}
if (redo) {
goto recompileObj;
}
}
}
/*
* Increment the code's ref count while it is being executed. If
* afterwards no references to it remain, free the code.
*/
runCompiledObj:
return codePtr;
}
recompileObj:
iPtr->errorLine = 1;
/*
* TIP #280. Remember the invoker for a moment in the interpreter
* structures so that the byte code compiler can pick it up when
* initializing the compilation environment, i.e. the extended location
* information.
*/
iPtr->invokeCmdFramePtr = invoker;
iPtr->invokeWord = word;
tclByteCodeType.setFromAnyProc(interp, objPtr);
iPtr->invokeCmdFramePtr = NULL;
codePtr = objPtr->internalRep.otherValuePtr;
if (iPtr->varFramePtr->localCachePtr) {
codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr;
codePtr->localCachePtr->refCount++;
}
goto runCompiledObj;
}
|
| ︙ | ︙ | |||
1863 1864 1865 1866 1867 1868 1869 |
#define ReadTraced(varPtr) ((varPtr)->flags & VAR_TRACED_READ)
#define WriteTraced(varPtr) ((varPtr)->flags & VAR_TRACED_WRITE)
/*
* Bottom of allocated stack holds the NR data
*/
| < < < < < < | > | < < | > > > > > > > > > > > > > | | > > | > > > > > > > > > > > > > > > > > > > > > > < < | | < < < < < < | < < < < < < < < < < > | | < < < | | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | < | < | < < < | < | < < | | | | | | | | | | | | | | | | | | | | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 |
#define ReadTraced(varPtr) ((varPtr)->flags & VAR_TRACED_READ)
#define WriteTraced(varPtr) ((varPtr)->flags & VAR_TRACED_WRITE)
/*
* Bottom of allocated stack holds the NR data
*/
/* NR_TEBC */
/*
* Constants: variables that do not change during the execution, used
* sporadically: no special need for speed.
*/
struct auxTEBCdata {
ExecStack *esPtr;
Var *compiledLocals;
BottomData *bottomPtr; /* Bottom of stack holds NR data */
BottomData *oldBottomPtr;
Tcl_Obj **constants;
int instructionCount; /* Counter that is used to work out when to
* call Tcl_AsyncReady() */
int checkInterp; /* Indicates when a check of interp readyness
* is necessary. Set by CACHE_STACK_INFO() */
const char *curInstName;
int result; /* Return code returned after execution.
* Result variable - needed only when going to
* checkForcatch or other error handlers; also
* used as local in some opcodes. */
} TAUX = {
NULL,
NULL,
NULL,
NULL,
&iPtr->execEnvPtr->constants[0],
0,
0,
NULL,
TCL_OK
};
#define LOCAL(i) (&(TAUX.compiledLocals[(i)]))
#define TCONST(i) (TAUX.constants[(i)])
#define BP (TAUX.bottomPtr)
#define OBP (TAUX.oldBottomPtr)
#define TRESULT (TAUX.result)
/*
* These macros are just meant to save some global variables that are not
* used too frequently
*/
#define bcFramePtr ((CmdFrame *) (BP + 1))
#define initCatchTop (((ptrdiff_t *) (bcFramePtr + 1)) - 1)
#define initTosPtr ((Tcl_Obj **) (initCatchTop+codePtr->maxExceptDepth))
#define auxObjList (BP->auxObjList)
#define catchTop (BP->catchTop)
/*
* Globals: variables that store state, must remain valid at all times.
*/
Tcl_Obj **tosPtr = NULL; /* Cached pointer to top of evaluation
* stack. */
const unsigned char *pc = NULL;
/* The current program counter. */
/*
* Transfer variables - needed only between opcodes, but not while
* executing an instruction.
*/
int cleanup = 0;
Tcl_Obj *objResultPtr;
/*
* Locals - variables that are used within opcodes or bounded sections of
* the file (jumps between opcodes within a family).
* NOTE: These are now defined locally where needed.
*/
#ifdef TCL_COMPILE_DEBUG
int traceInstructions = (tclTraceExec == 3);
char cmdNameBuf[21];
#endif
/*
* The execution uses a unified stack: first a BottomData, immediately
* above it a CmdFrame, then the catch stack, then the execution stack.
*
* Make sure the catch stack is large enough to hold the maximum number of
* catch commands that could ever be executing at the same time (this will
* be no more than the exception range array's depth). Make sure the
* execution stack is large enough to execute this ByteCode.
*/
if (!codePtr) {
resumeCoroutine:
/*
* Reawakening a suspended coroutine: the [yield] command is
* returning.
*/
NRE_ASSERT(iPtr->execEnvPtr->corPtr->eePtr == iPtr->execEnvPtr);
NRE_ASSERT(iPtr->execEnvPtr->corPtr != NULL);
NRE_ASSERT(iPtr->execEnvPtr->corPtr->eePtr == iPtr->execEnvPtr);
NRE_ASSERT(COR_IS_SUSPENDED(iPtr->execEnvPtr->corPtr));
OBP = iPtr->execEnvPtr->bottomPtr;
iPtr->execEnvPtr->corPtr->stackLevel = &TAUX;
if (iPtr->execEnvPtr->rewind) {
TRESULT = TCL_ERROR;
}
goto returnToCaller;
}
nonRecursiveCallStart:
codePtr->refCount++;
BP = (BottomData *) GrowEvaluationStack(iPtr->execEnvPtr,
sizeof(BottomData) + codePtr->maxExceptDepth + sizeof(CmdFrame)
+ codePtr->maxStackDepth, 0);
TAUX.curInstName = NULL;
auxObjList = NULL;
NR_DATA_INIT(); /* record this level's data */
if (iPtr->execEnvPtr->corPtr && !iPtr->execEnvPtr->corPtr->stackLevel) {
iPtr->execEnvPtr->corPtr->stackLevel = &TAUX;
}
iPtr->execEnvPtr->bottomPtr = BP;
TAUX.esPtr = iPtr->execEnvPtr->execStackPtr;
TAUX.compiledLocals = iPtr->varFramePtr->compiledLocals;//
pc = codePtr->codeStart;
catchTop = initCatchTop;
tosPtr = initTosPtr;
/*
* TIP #280: Initialize the frame. Do not push it yet.
*/
bcFramePtr->type = ((codePtr->flags & TCL_BYTECODE_PRECOMPILED)
? TCL_LOCATION_PREBC : TCL_LOCATION_BC);
bcFramePtr->level = (iPtr->cmdFramePtr ? iPtr->cmdFramePtr->level+1 : 1);
bcFramePtr->numLevels = iPtr->numLevels;
bcFramePtr->framePtr = iPtr->framePtr;
bcFramePtr->nextPtr = iPtr->cmdFramePtr;
bcFramePtr->nline = 0;
bcFramePtr->line = NULL;
bcFramePtr->litarg = NULL;
bcFramePtr->data.tebc.codePtr = codePtr;
bcFramePtr->data.tebc.pc = NULL;
bcFramePtr->cmd.str.cmd = NULL;
bcFramePtr->cmd.str.len = 0;
if (iPtr->execEnvPtr->rewind) {
TRESULT = TCL_ERROR;
goto abnormalReturn;
}
#ifdef TCL_COMPILE_DEBUG
if (tclTraceExec >= 2) {
PrintByteCodeInfo(codePtr);
fprintf(stdout, " Starting stack top=%d\n", (int) CURR_DEPTH);
fflush(stdout);
|
| ︙ | ︙ | |||
2273 2274 2275 2276 2277 2278 2279 |
#endif
/*
* Check for asynchronous handlers [Bug 746722]; we do the check every
* ASYNC_CHECK_COUNT_MASK instruction, of the form (2**n-1).
*/
| | | | | | | 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 |
#endif
/*
* Check for asynchronous handlers [Bug 746722]; we do the check every
* ASYNC_CHECK_COUNT_MASK instruction, of the form (2**n-1).
*/
if ((TAUX.instructionCount++ & ASYNC_CHECK_COUNT_MASK) == 0) {
/*
* Check for asynchronous handlers [Bug 746722]; we do the check every
* ASYNC_CHECK_COUNT_MASK instruction, of the form (2**n-<1).
*/
int localResult;
if (TclAsyncReady(iPtr)) {
DECACHE_STACK_INFO();
localResult = Tcl_AsyncInvoke(interp, TRESULT);
CACHE_STACK_INFO();
if (localResult == TCL_ERROR) {
TRESULT = localResult;
goto checkForCatch;
}
}
DECACHE_STACK_INFO();
localResult = Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG);
CACHE_STACK_INFO();
if (localResult == TCL_ERROR) {
TRESULT = TCL_ERROR;
goto checkForCatch;
}
if (TclLimitReady(iPtr->limit)) {
DECACHE_STACK_INFO();
localResult = Tcl_LimitCheck(interp);
CACHE_STACK_INFO();
if (localResult == TCL_ERROR) {
TRESULT = localResult;
goto checkForCatch;
}
}
}
TCL_DTRACE_INST_NEXT();
|
| ︙ | ︙ | |||
2338 2339 2340 2341 2342 2343 2344 |
int level = TclGetUInt4AtPtr(pc+5);
/*
* OBJ_AT_TOS is returnOpts, OBJ_UNDER_TOS is resultObjPtr.
*/
TRACE(("%u %u => ", code, level));
| | | | | | | | | 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 |
int level = TclGetUInt4AtPtr(pc+5);
/*
* OBJ_AT_TOS is returnOpts, OBJ_UNDER_TOS is resultObjPtr.
*/
TRACE(("%u %u => ", code, level));
TRESULT = TclProcessReturn(interp, code, level, OBJ_AT_TOS);
if (TRESULT == TCL_OK) {
TRACE_APPEND(("continuing to next instruction (TRESULT=\"%.30s\")",
O2S(objResultPtr)));
NEXT_INST_F(9, 1, 0);
} else {
Tcl_SetObjResult(interp, OBJ_UNDER_TOS);
if (*pc == INST_SYNTAX) {
iPtr->flags &= ~ERR_ALREADY_LOGGED;
}
cleanup = 2;
goto processExceptionReturn;
}
}
case INST_RETURN_STK:
TRACE(("=> "));
objResultPtr = POP_OBJECT();
TRESULT = Tcl_SetReturnOptions(interp, OBJ_AT_TOS);
Tcl_DecrRefCount(OBJ_AT_TOS);
OBJ_AT_TOS = objResultPtr;
if (TRESULT == TCL_OK) {
TRACE_APPEND(("continuing to next instruction (TRESULT=\"%.30s\")",
O2S(objResultPtr)));
NEXT_INST_F(1, 0, 0);
} else {
Tcl_SetObjResult(interp, objResultPtr);
cleanup = 1;
goto processExceptionReturn;
}
case INST_DONE:
if (tosPtr > initTosPtr) {
/*
* Set the interpreter's object result to point to the topmost
* object from the stack, and check for a possible [catch]. The
* stackTop's level and refCount will be handled by "processCatch"
* or "abnormalReturn".
*/
Tcl_SetObjResult(interp, OBJ_AT_TOS);
#ifdef TCL_COMPILE_DEBUG
TRACE_WITH_OBJ(("=> return code=%d, result=", TRESULT),
iPtr->objResultPtr);
if (traceInstructions) {
fprintf(stdout, "\n");
}
#endif
goto checkForCatch;
} else {
|
| ︙ | ︙ | |||
2449 2450 2451 2452 2453 2454 2455 | * Remark that if the interpreter is marked for deletion its * compileEpoch is modified, so that the epoch check also verifies * that the interp is not deleted. If no outside call has been made * since the last check, it is safe to omit the check. */ iPtr->cmdCount += TclGetUInt4AtPtr(pc+5); | | | | | | | | | < | | > | 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 |
* Remark that if the interpreter is marked for deletion its
* compileEpoch is modified, so that the epoch check also verifies
* that the interp is not deleted. If no outside call has been made
* since the last check, it is safe to omit the check.
*/
iPtr->cmdCount += TclGetUInt4AtPtr(pc+5);
if (!TAUX.checkInterp) {
instStartCmdOK:
NEXT_INST_F(9, 0, 0);
} else if (((codePtr->compileEpoch == iPtr->compileEpoch)
&& (codePtr->nsEpoch == iPtr->varFramePtr->nsPtr->resolverEpoch))
|| (codePtr->flags & TCL_BYTECODE_PRECOMPILED)) {
TAUX.checkInterp = 0;
goto instStartCmdOK;
} else {
const char *bytes;
int length = 0, opnd;
Tcl_Obj *newObjResultPtr;
bytes = GetSrcInfoForPc(pc, codePtr, &length);
DECACHE_STACK_INFO();
TRESULT = Tcl_EvalEx(interp, bytes, length, 0);
CACHE_STACK_INFO();
if (TRESULT != TCL_OK) {
cleanup = 0;
if (TRESULT == TCL_ERROR) {
/*
* Tcl_EvalEx already did the task of logging the error to
* the stack trace for us, so set a flag to prevent the
* TEBC exception handling machinery from trying to do it
* again. See test execute-8.4. [Bug 2037338]
*/
iPtr->flags |= ERR_ALREADY_LOGGED;
}
goto processExceptionReturn;
}
opnd = TclGetUInt4AtPtr(pc+1);
objResultPtr = Tcl_GetObjResult(interp);
TclNewObj(newObjResultPtr);
|
| ︙ | ︙ | |||
2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 |
Tcl_Obj **a, **b;
opnd = TclGetUInt4AtPtr(pc+1);
a = tosPtr-(opnd-1);
b = tosPtr;
while (a<b) {
Tcl_Obj *temp = *a;
*a = *b;
*b = temp;
a++; b--;
}
NEXT_INST_F(5, 0, 0);
}
| > | 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 |
Tcl_Obj **a, **b;
opnd = TclGetUInt4AtPtr(pc+1);
a = tosPtr-(opnd-1);
b = tosPtr;
while (a<b) {
Tcl_Obj *temp = *a;
*a = *b;
*b = temp;
a++; b--;
}
NEXT_INST_F(5, 0, 0);
}
|
| ︙ | ︙ | |||
2690 2691 2692 2693 2694 2695 2696 | * error, also in INST_EXPAND_STKTOP). */ Tcl_Obj *objPtr; TclNewObj(objPtr); objPtr->internalRep.twoPtrValue.ptr1 = (void *) CURR_DEPTH; | | | | | < < < < | | 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 |
* error, also in INST_EXPAND_STKTOP).
*/
Tcl_Obj *objPtr;
TclNewObj(objPtr);
objPtr->internalRep.twoPtrValue.ptr1 = (void *) CURR_DEPTH;
PUSH_TAUX_OBJ(objPtr);
NEXT_INST_F(1, 0, 0);
}
case INST_EXPAND_STKTOP: {
int objc, length, i;
Tcl_Obj **objv, *valuePtr;
ptrdiff_t moved;
/*
* Make sure that the element at stackTop is a list; if not, just
* leave with an error. Note that the element from the expand list
* will be removed at checkForCatch.
*/
valuePtr = OBJ_AT_TOS;
if (TclListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK){
TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(valuePtr)),
Tcl_GetObjResult(interp));
TRESULT = TCL_ERROR;
goto checkForCatch;
}
(void) POP_OBJECT();
/*
* Make sure there is enough room in the stack to expand this list
* *and* process the rest of the command (at least up to the next
* argument expansion or command end). The operand is the current
* stack depth, as seen by the compiler.
*/
length = objc + (codePtr->maxStackDepth - TclGetInt4AtPtr(pc+1));
DECACHE_STACK_INFO();
moved = GrowEvaluationStack(iPtr->execEnvPtr, length, 1)
- (Tcl_Obj **) BP;
if (moved) {
/*
* Change the global data to point to the new stack: move the
* bottomPtr, recompute the position of every other
* stack-allocated parameter, update the stack pointers.
*/
BP = (BottomData *) (((Tcl_Obj **)BP) + moved);
TAUX.esPtr = iPtr->execEnvPtr->execStackPtr;
catchTop += moved;
tosPtr += moved;
}
/*
* Expand the list at stacktop onto the stack; free the list. Knowing
|
| ︙ | ︙ | |||
2772 2773 2774 2775 2776 2777 2778 | bcFramePtr->data.tebc.pc = (char *) pc; iPtr->cmdFramePtr = bcFramePtr; DECACHE_STACK_INFO(); newCodePtr = CompileExprObj(interp, OBJ_AT_TOS); CACHE_STACK_INFO(); cleanup = 1; pc++; | > | < | 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 |
bcFramePtr->data.tebc.pc = (char *) pc;
iPtr->cmdFramePtr = bcFramePtr;
DECACHE_STACK_INFO();
newCodePtr = CompileExprObj(interp, OBJ_AT_TOS);
CACHE_STACK_INFO();
cleanup = 1;
pc++;
NR_DATA_BURY();
codePtr = newCodePtr;
goto nonRecursiveCallStart;
}
{
/*
* INVOCATION BLOCK
*/
|
| ︙ | ︙ | |||
2838 2839 2840 2841 2842 2843 2844 | */ DECACHE_STACK_INFO(); newCodePtr = TclCompileObj(interp, objPtr, NULL, 0); bcFramePtr->data.tebc.pc = (char *) pc; iPtr->cmdFramePtr = bcFramePtr; pc++; | > | < | | 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 |
*/
DECACHE_STACK_INFO();
newCodePtr = TclCompileObj(interp, objPtr, NULL, 0);
bcFramePtr->data.tebc.pc = (char *) pc;
iPtr->cmdFramePtr = bcFramePtr;
pc++;
NR_DATA_BURY();
codePtr = newCodePtr;
goto nonRecursiveCallStart;
}
case INST_INVOKE_EXPANDED:
{
CLANG_ASSERT(auxObjList);
objc = CURR_DEPTH
- (ptrdiff_t) auxObjList->internalRep.twoPtrValue.ptr1;
POP_TAUX_OBJ();
}
if (objc) {
pcAdjustment = 1;
goto doInvocation;
} else {
/*
|
| ︙ | ︙ | |||
2913 2914 2915 2916 2917 2918 2919 | iPtr->cmdFramePtr = bcFramePtr; /* * Reset the instructionCount variable, since we're about to check * for async stuff anyway while processing TclEvalObjv */ | | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > | | > > > > > > > > | > > > | > > | > | | | | 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 |
iPtr->cmdFramePtr = bcFramePtr;
/*
* Reset the instructionCount variable, since we're about to check
* for async stuff anyway while processing TclEvalObjv
*/
TAUX.instructionCount = 1;
TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc,
codePtr, bcFramePtr, pc - codePtr->codeStart);
DECACHE_STACK_INFO();
TRESULT = TclNREvalObjv(interp, objc, objv,
(*pc == INST_EVAL_STK) ? 0 : TCL_EVAL_NOERR, NULL);
TRESULT = TclNRRunCallbacks(interp, TRESULT, BP->rootPtr, 1);
CACHE_STACK_INFO();
if (TOP_CB(interp) != BP->rootPtr) {
NRE_ASSERT(TRESULT == TCL_OK);
pc += pcAdjustment;
nonRecursiveCallSetup: {
TEOV_callback *callbackPtr = TOP_CB(interp);
int type = PTR2INT(callbackPtr->data[0]);
ClientData param = callbackPtr->data[1];
NRE_ASSERT(callbackPtr != BP->rootPtr);
NRE_ASSERT(callbackPtr->procPtr == NRCallTEBC);
TOP_CB(interp) = callbackPtr->nextPtr;
TCLNR_FREE(interp, callbackPtr);
NR_DATA_BURY();
switch (type) {
case TCL_NR_BC_TYPE:
/*
* A request to run a bytecode: record this level's
* state variables, swap codePtr and start running the
* new one.
*/
if (param) {
codePtr = param;
goto nonRecursiveCallStart;
}
/* NOT CALLED, does not (yet?) work */
goto resumeCoroutine;
case TCL_NR_TAILCALL_TYPE:
/*
* A request to perform a tailcall: just drop this
* bytecode.
*/
#ifdef TCL_COMPILE_DEBUG
if (traceInstructions) {
fprintf(stdout, " Tailcall request received\n");
}
#endif /* TCL_COMPILE_DEBUG */
if (catchTop != initCatchTop) {
TEOV_callback *tailcallPtr =
iPtr->varFramePtr->tailcallPtr;
TclClearTailcall(interp, tailcallPtr);
iPtr->varFramePtr->tailcallPtr = NULL;
TRESULT = TCL_ERROR;
Tcl_SetResult(interp,
"Tailcall called from within a catch environment",
TCL_STATIC);
Tcl_SetErrorCode(interp, "TCL", "TAILCALL",
"ILLEGAL", NULL);
pc--;
goto checkForCatch;
}
goto abnormalReturn;
case TCL_NR_YIELD_TYPE: { /* [yield] */
CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
if (!corPtr) {
Tcl_SetResult(interp,
"yield can only be called in a coroutine",
TCL_STATIC);
Tcl_SetErrorCode(interp, "TCL", "COROUTINE",
"ILLEGAL_YIELD", NULL);
TRESULT = TCL_ERROR;
pc--;
goto checkForCatch;
}
NRE_ASSERT(iPtr->execEnvPtr == corPtr->eePtr);
NRE_ASSERT(corPtr->stackLevel != NULL);
NRE_ASSERT(BP == corPtr->eePtr->bottomPtr);
if (corPtr->stackLevel != &TAUX) {
Tcl_SetResult(interp,
"cannot yield: C stack busy", TCL_STATIC);
Tcl_SetErrorCode(interp, "TCL", "COROUTINE",
"CANT_YIELD", NULL);
TRESULT = TCL_ERROR;
pc--;
goto checkForCatch;
}
/*
* Save our state and return
*/
NR_DATA_BURY();
TAUX.esPtr->tosPtr = tosPtr;
iPtr->execEnvPtr->bottomPtr = BP;
return TCL_OK;
}
default:
Tcl_Panic("TEBC: TRCB sent us a callback we cannot handle!");
}
}
}
pc += pcAdjustment;
nonRecursiveCallReturn:
NRE_ASSERT(iPtr->cmdFramePtr == bcFramePtr);
iPtr->cmdFramePtr = bcFramePtr->nextPtr;
TclArgumentBCRelease((Tcl_Interp *) iPtr, bcFramePtr);
/*
* If the CallFrame is marked as tailcalling, keep tailcalling
*/
if (iPtr->varFramePtr->tailcallPtr) {
if (catchTop != initCatchTop) {
TclClearTailcall(interp, iPtr->varFramePtr->tailcallPtr);
iPtr->varFramePtr->tailcallPtr = NULL;
TRESULT = TCL_ERROR;
Tcl_SetResult(interp,"Tailcall called from within a catch environment",
TCL_STATIC);
pc--;
goto checkForCatch;
}
goto abnormalReturn;
}
if (iPtr->execEnvPtr->rewind) {
TRESULT = TCL_ERROR;
goto abnormalReturn;
}
if (TRESULT == TCL_OK) {
Tcl_Obj *objPtr;
#ifndef TCL_COMPILE_DEBUG
if (*pc == INST_POP) {
NEXT_INST_V(1, cleanup, 0);
}
#endif
/*
* Push the call's object result and continue execution with
* the next instruction.
*/
|
| ︙ | ︙ | |||
2971 2972 2973 2974 2975 2976 2977 | * keeps the refCount it had in its role of * iPtr->objResultPtr. */ TclNewObj(objPtr); Tcl_IncrRefCount(objPtr); iPtr->objResultPtr = objPtr; | | > | 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 |
* keeps the refCount it had in its role of
* iPtr->objResultPtr.
*/
TclNewObj(objPtr);
Tcl_IncrRefCount(objPtr);
iPtr->objResultPtr = objPtr;
NEXT_INST_V(0, cleanup, -1);
} else {
pc--;
goto processExceptionReturn;
}
}
#if TCL_SUPPORT_84_BYTECODE
case INST_CALL_BUILTIN_FUNC1: {
/*
|
| ︙ | ︙ | |||
3088 3089 3090 3091 3092 3093 3094 |
Tcl_Obj *part1Ptr, *part2Ptr;
Var *varPtr, *arrayPtr;
Tcl_Obj *objPtr;
case INST_LOAD_SCALAR1:
instLoadScalar1:
opnd = TclGetUInt1AtPtr(pc+1);
| | | 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 |
Tcl_Obj *part1Ptr, *part2Ptr;
Var *varPtr, *arrayPtr;
Tcl_Obj *objPtr;
case INST_LOAD_SCALAR1:
instLoadScalar1:
opnd = TclGetUInt1AtPtr(pc+1);
varPtr = LOCAL(opnd);
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
TRACE(("%u => ", opnd));
if (TclIsVarDirectReadable(varPtr)) {
/*
* No errors, no traces: just get the value.
|
| ︙ | ︙ | |||
3110 3111 3112 3113 3114 3115 3116 |
cleanup = 0;
arrayPtr = NULL;
part1Ptr = part2Ptr = NULL;
goto doCallPtrGetVar;
case INST_LOAD_SCALAR4:
opnd = TclGetUInt4AtPtr(pc+1);
| | | 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 |
cleanup = 0;
arrayPtr = NULL;
part1Ptr = part2Ptr = NULL;
goto doCallPtrGetVar;
case INST_LOAD_SCALAR4:
opnd = TclGetUInt4AtPtr(pc+1);
varPtr = LOCAL(opnd);
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
TRACE(("%u => ", opnd));
if (TclIsVarDirectReadable(varPtr)) {
/*
* No errors, no traces: just get the value.
|
| ︙ | ︙ | |||
3142 3143 3144 3145 3146 3147 3148 |
case INST_LOAD_ARRAY1:
opnd = TclGetUInt1AtPtr(pc+1);
pcAdjustment = 2;
doLoadArray:
part1Ptr = NULL;
part2Ptr = OBJ_AT_TOS;
| | | 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 |
case INST_LOAD_ARRAY1:
opnd = TclGetUInt1AtPtr(pc+1);
pcAdjustment = 2;
doLoadArray:
part1Ptr = NULL;
part2Ptr = OBJ_AT_TOS;
arrayPtr = LOCAL(opnd);
while (TclIsVarLink(arrayPtr)) {
arrayPtr = arrayPtr->value.linkPtr;
}
TRACE(("%u \"%.30s\" => ", opnd, O2S(part2Ptr)));
if (TclIsVarArray(arrayPtr) && !ReadTraced(arrayPtr)) {
varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr);
if (varPtr && TclIsVarDirectReadable(varPtr)) {
|
| ︙ | ︙ | |||
3164 3165 3166 3167 3168 3169 3170 |
}
}
varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr,
TCL_LEAVE_ERR_MSG, "read", 0, 1, arrayPtr, opnd);
if (varPtr == NULL) {
TRACE_APPEND(("ERROR: %.30s\n",
O2S(Tcl_GetObjResult(interp))));
| | | 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 |
}
}
varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr,
TCL_LEAVE_ERR_MSG, "read", 0, 1, arrayPtr, opnd);
if (varPtr == NULL) {
TRACE_APPEND(("ERROR: %.30s\n",
O2S(Tcl_GetObjResult(interp))));
TRESULT = TCL_ERROR;
goto checkForCatch;
}
cleanup = 1;
goto doCallPtrGetVar;
case INST_LOAD_ARRAY_STK:
cleanup = 2;
|
| ︙ | ︙ | |||
3204 3205 3206 3207 3208 3209 3210 |
NEXT_INST_V(1, cleanup, 1);
}
pcAdjustment = 1;
opnd = -1;
goto doCallPtrGetVar;
} else {
TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
| | | | 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 |
NEXT_INST_V(1, cleanup, 1);
}
pcAdjustment = 1;
opnd = -1;
goto doCallPtrGetVar;
} else {
TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
TRESULT = TCL_ERROR;
goto checkForCatch;
}
doCallPtrGetVar:
/*
* There are either errors or the variable is traced: call
* TclPtrGetVar to process fully.
*/
DECACHE_STACK_INFO();
objResultPtr = TclPtrGetVar(interp, varPtr, arrayPtr,
part1Ptr, part2Ptr, TCL_LEAVE_ERR_MSG, opnd);
CACHE_STACK_INFO();
if (objResultPtr) {
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
NEXT_INST_V(pcAdjustment, cleanup, 1);
} else {
TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
TRESULT = TCL_ERROR;
goto checkForCatch;
}
}
/*
* End of INST_LOAD instructions.
* ---------------------------------------------------------
|
| ︙ | ︙ | |||
3260 3261 3262 3263 3264 3265 3266 |
case INST_STORE_ARRAY1:
opnd = TclGetUInt1AtPtr(pc+1);
pcAdjustment = 2;
doStoreArrayDirect:
valuePtr = OBJ_AT_TOS;
part2Ptr = OBJ_UNDER_TOS;
| | | 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 |
case INST_STORE_ARRAY1:
opnd = TclGetUInt1AtPtr(pc+1);
pcAdjustment = 2;
doStoreArrayDirect:
valuePtr = OBJ_AT_TOS;
part2Ptr = OBJ_UNDER_TOS;
arrayPtr = LOCAL(opnd);
TRACE(("%u \"%.30s\" <- \"%.30s\" => ", opnd, O2S(part2Ptr),
O2S(valuePtr)));
while (TclIsVarLink(arrayPtr)) {
arrayPtr = arrayPtr->value.linkPtr;
}
if (TclIsVarArray(arrayPtr) && !WriteTraced(arrayPtr)) {
varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr);
|
| ︙ | ︙ | |||
3291 3292 3293 3294 3295 3296 3297 |
case INST_STORE_SCALAR1:
opnd = TclGetUInt1AtPtr(pc+1);
pcAdjustment = 2;
doStoreScalarDirect:
valuePtr = OBJ_AT_TOS;
| | | 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 |
case INST_STORE_SCALAR1:
opnd = TclGetUInt1AtPtr(pc+1);
pcAdjustment = 2;
doStoreScalarDirect:
valuePtr = OBJ_AT_TOS;
varPtr = LOCAL(opnd);
TRACE(("%u <- \"%.30s\" => ", opnd, O2S(valuePtr)));
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
if (TclIsVarDirectWritable(varPtr)) {
doStoreVarDirect:
/*
|
| ︙ | ︙ | |||
3383 3384 3385 3386 3387 3388 3389 |
if (varPtr) {
cleanup = ((part2Ptr == NULL)? 2 : 3);
pcAdjustment = 1;
opnd = -1;
goto doCallPtrSetVar;
} else {
TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
| | | 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 |
if (varPtr) {
cleanup = ((part2Ptr == NULL)? 2 : 3);
pcAdjustment = 1;
opnd = -1;
goto doCallPtrSetVar;
} else {
TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
TRESULT = TCL_ERROR;
goto checkForCatch;
}
case INST_LAPPEND_ARRAY4:
opnd = TclGetUInt4AtPtr(pc+1);
pcAdjustment = 5;
storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
|
| ︙ | ︙ | |||
3416 3417 3418 3419 3420 3421 3422 |
pcAdjustment = 2;
storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
goto doStoreArray;
doStoreArray:
valuePtr = OBJ_AT_TOS;
part2Ptr = OBJ_UNDER_TOS;
| | | | 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 |
pcAdjustment = 2;
storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
goto doStoreArray;
doStoreArray:
valuePtr = OBJ_AT_TOS;
part2Ptr = OBJ_UNDER_TOS;
arrayPtr = LOCAL(opnd);
TRACE(("%u \"%.30s\" <- \"%.30s\" => ", opnd, O2S(part2Ptr),
O2S(valuePtr)));
while (TclIsVarLink(arrayPtr)) {
arrayPtr = arrayPtr->value.linkPtr;
}
cleanup = 2;
part1Ptr = NULL;
doStoreArrayDirectFailed:
varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr,
TCL_LEAVE_ERR_MSG, "set", 1, 1, arrayPtr, opnd);
if (varPtr) {
goto doCallPtrSetVar;
} else {
TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
TRESULT = TCL_ERROR;
goto checkForCatch;
}
case INST_LAPPEND_SCALAR4:
opnd = TclGetUInt4AtPtr(pc+1);
pcAdjustment = 5;
storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
|
| ︙ | ︙ | |||
3464 3465 3466 3467 3468 3469 3470 |
opnd = TclGetUInt1AtPtr(pc+1);
pcAdjustment = 2;
storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
goto doStoreScalar;
doStoreScalar:
valuePtr = OBJ_AT_TOS;
| | | 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 |
opnd = TclGetUInt1AtPtr(pc+1);
pcAdjustment = 2;
storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
goto doStoreScalar;
doStoreScalar:
valuePtr = OBJ_AT_TOS;
varPtr = LOCAL(opnd);
TRACE(("%u <- \"%.30s\" => ", opnd, O2S(valuePtr)));
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
cleanup = 1;
arrayPtr = NULL;
part1Ptr = part2Ptr = NULL;
|
| ︙ | ︙ | |||
3488 3489 3490 3491 3492 3493 3494 |
NEXT_INST_V((pcAdjustment+1), cleanup, 0);
}
#endif
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
NEXT_INST_V(pcAdjustment, cleanup, 1);
} else {
TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
| | | 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 |
NEXT_INST_V((pcAdjustment+1), cleanup, 0);
}
#endif
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
NEXT_INST_V(pcAdjustment, cleanup, 1);
} else {
TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
TRESULT = TCL_ERROR;
goto checkForCatch;
}
}
/*
* End of INST_STORE and related instructions.
* ---------------------------------------------------------
|
| ︙ | ︙ | |||
3569 3570 3571 3572 3573 3574 3575 |
if (varPtr) {
cleanup = ((part2Ptr == NULL)? 1 : 2);
goto doIncrVar;
} else {
Tcl_AddObjErrorInfo(interp,
"\n (reading value of variable to increment)", -1);
TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
| | | | | | 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 |
if (varPtr) {
cleanup = ((part2Ptr == NULL)? 1 : 2);
goto doIncrVar;
} else {
Tcl_AddObjErrorInfo(interp,
"\n (reading value of variable to increment)", -1);
TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
TRESULT = TCL_ERROR;
Tcl_DecrRefCount(incrPtr);
goto checkForCatch;
}
case INST_INCR_ARRAY1_IMM:
opnd = TclGetUInt1AtPtr(pc+1);
i = TclGetInt1AtPtr(pc+2);
incrPtr = Tcl_NewIntObj(i);
Tcl_IncrRefCount(incrPtr);
pcAdjustment = 3;
doIncrArray:
part1Ptr = NULL;
part2Ptr = OBJ_AT_TOS;
arrayPtr = LOCAL(opnd);
cleanup = 1;
while (TclIsVarLink(arrayPtr)) {
arrayPtr = arrayPtr->value.linkPtr;
}
TRACE(("%u \"%.30s\" (by %ld) => ", opnd, O2S(part2Ptr), i));
varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr,
TCL_LEAVE_ERR_MSG, "read", 1, 1, arrayPtr, opnd);
if (varPtr) {
goto doIncrVar;
} else {
TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
TRESULT = TCL_ERROR;
Tcl_DecrRefCount(incrPtr);
goto checkForCatch;
}
case INST_INCR_SCALAR1_IMM:
opnd = TclGetUInt1AtPtr(pc+1);
i = TclGetInt1AtPtr(pc+2);
pcAdjustment = 3;
cleanup = 0;
varPtr = LOCAL(opnd);
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
if (TclIsVarDirectModifyable(varPtr)) {
ClientData ptr;
int type;
|
| ︙ | ︙ | |||
3707 3708 3709 3710 3711 3712 3713 |
objResultPtr = Tcl_DuplicateObj(objPtr);
Tcl_IncrRefCount(objResultPtr);
varPtr->value.objPtr = objResultPtr;
} else {
objResultPtr = objPtr;
}
TclNewLongObj(incrPtr, i);
| | | | | | | | 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 |
objResultPtr = Tcl_DuplicateObj(objPtr);
Tcl_IncrRefCount(objResultPtr);
varPtr->value.objPtr = objResultPtr;
} else {
objResultPtr = objPtr;
}
TclNewLongObj(incrPtr, i);
TRESULT = TclIncrObj(interp, objResultPtr, incrPtr);
Tcl_DecrRefCount(incrPtr);
if (TRESULT == TCL_OK) {
goto doneIncr;
} else {
TRACE_APPEND(("ERROR: %.30s\n",
O2S(Tcl_GetObjResult(interp))));
goto checkForCatch;
}
}
/*
* All other cases, flow through to generic handling.
*/
TclNewLongObj(incrPtr, i);
Tcl_IncrRefCount(incrPtr);
doIncrScalar:
varPtr = LOCAL(opnd);
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
arrayPtr = NULL;
part1Ptr = part2Ptr = NULL;
cleanup = 0;
TRACE(("%u %ld => ", opnd, i));
doIncrVar:
if (TclIsVarDirectModifyable2(varPtr, arrayPtr)) {
objPtr = varPtr->value.objPtr;
if (Tcl_IsShared(objPtr)) {
objPtr->refCount--; /* We know it's shared */
objResultPtr = Tcl_DuplicateObj(objPtr);
Tcl_IncrRefCount(objResultPtr);
varPtr->value.objPtr = objResultPtr;
} else {
objResultPtr = objPtr;
}
TRESULT = TclIncrObj(interp, objResultPtr, incrPtr);
Tcl_DecrRefCount(incrPtr);
if (TRESULT == TCL_OK) {
goto doneIncr;
} else {
TRACE_APPEND(("ERROR: %.30s\n",
O2S(Tcl_GetObjResult(interp))));
goto checkForCatch;
}
} else {
DECACHE_STACK_INFO();
objResultPtr = TclPtrIncrObjVar(interp, varPtr, arrayPtr,
part1Ptr, part2Ptr, incrPtr, TCL_LEAVE_ERR_MSG, opnd);
CACHE_STACK_INFO();
Tcl_DecrRefCount(incrPtr);
if (objResultPtr == NULL) {
TRACE_APPEND(("ERROR: %.30s\n",
O2S(Tcl_GetObjResult(interp))));
TRESULT = TCL_ERROR;
goto checkForCatch;
}
}
doneIncr:
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
#ifndef TCL_COMPILE_DEBUG
if (*(pc+pcAdjustment) == INST_POP) {
|
| ︙ | ︙ | |||
3794 3795 3796 3797 3798 3799 3800 |
{
Tcl_Obj *part1Ptr, *part2Ptr;
Var *varPtr, *arrayPtr;
case INST_EXIST_SCALAR: {
int opnd = TclGetUInt4AtPtr(pc+1);
| | | | | 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 |
{
Tcl_Obj *part1Ptr, *part2Ptr;
Var *varPtr, *arrayPtr;
case INST_EXIST_SCALAR: {
int opnd = TclGetUInt4AtPtr(pc+1);
varPtr = LOCAL(opnd);
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
TRACE(("%u => ", opnd));
if (ReadTraced(varPtr)) {
DECACHE_STACK_INFO();
TclObjCallVarTraces(iPtr, NULL, varPtr, NULL, NULL,
TCL_TRACE_READS, 0, opnd);
CACHE_STACK_INFO();
if (TclIsVarUndefined(varPtr)) {
TclCleanupVar(varPtr, NULL);
varPtr = NULL;
}
}
/*
* Tricky! Arrays always exist.
*/
objResultPtr = TCONST(!varPtr || TclIsVarUndefined(varPtr) ? 0 : 1);
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
NEXT_INST_F(5, 0, 1);
}
case INST_EXIST_ARRAY: {
int opnd = TclGetUInt4AtPtr(pc+1);
part2Ptr = OBJ_AT_TOS;
arrayPtr = LOCAL(opnd);
while (TclIsVarLink(arrayPtr)) {
arrayPtr = arrayPtr->value.linkPtr;
}
TRACE(("%u \"%.30s\" => ", opnd, O2S(part2Ptr)));
if (TclIsVarArray(arrayPtr) && !ReadTraced(arrayPtr)) {
varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr);
if (!varPtr || !ReadTraced(varPtr)) {
|
| ︙ | ︙ | |||
3849 3850 3851 3852 3853 3854 3855 |
}
if (TclIsVarUndefined(varPtr)) {
TclCleanupVar(varPtr, arrayPtr);
varPtr = NULL;
}
}
doneExistArray:
| | | 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 |
}
if (TclIsVarUndefined(varPtr)) {
TclCleanupVar(varPtr, arrayPtr);
varPtr = NULL;
}
}
doneExistArray:
objResultPtr = TCONST(!varPtr || TclIsVarUndefined(varPtr) ? 0 : 1);
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
NEXT_INST_F(5, 1, 1);
}
case INST_EXIST_ARRAY_STK:
cleanup = 2;
part2Ptr = OBJ_AT_TOS; /* element name */
|
| ︙ | ︙ | |||
3882 3883 3884 3885 3886 3887 3888 |
CACHE_STACK_INFO();
}
if (TclIsVarUndefined(varPtr)) {
TclCleanupVar(varPtr, arrayPtr);
varPtr = NULL;
}
}
| | | | | | | | | | | | | 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 3953 3954 3955 3956 3957 3958 3959 3960 3961 3962 3963 |
CACHE_STACK_INFO();
}
if (TclIsVarUndefined(varPtr)) {
TclCleanupVar(varPtr, arrayPtr);
varPtr = NULL;
}
}
objResultPtr = TCONST(!varPtr || TclIsVarUndefined(varPtr) ? 0 : 1);
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
NEXT_INST_V(1, cleanup, 1);
}
/*
* End of INST_EXIST instructions.
* ---------------------------------------------------------
*/
case INST_UPVAR: {
int opnd;
Var *varPtr, *otherPtr;
TRACE_WITH_OBJ(("upvar "), OBJ_UNDER_TOS);
{
CallFrame *framePtr, *savedFramePtr;
TRESULT = TclObjGetFrame(interp, OBJ_UNDER_TOS, &framePtr);
if (TRESULT != -1) {
/*
* Locate the other variable.
*/
savedFramePtr = iPtr->varFramePtr;
iPtr->varFramePtr = framePtr;
otherPtr = TclObjLookupVarEx(interp, OBJ_AT_TOS, NULL,
(TCL_LEAVE_ERR_MSG), "access",
/*createPart1*/ 1, /*createPart2*/ 1, &varPtr);
iPtr->varFramePtr = savedFramePtr;
if (otherPtr) {
TRESULT = TCL_OK;
goto doLinkVars;
}
}
TRESULT = TCL_ERROR;
goto checkForCatch;
}
case INST_VARIABLE:
TRACE(("variable "));
otherPtr = TclObjLookupVarEx(interp, OBJ_AT_TOS, NULL,
(TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "access",
/*createPart1*/ 1, /*createPart2*/ 1, &varPtr);
if (otherPtr) {
/*
* Do the [variable] magic.
*/
TclSetVarNamespaceVar(otherPtr);
TRESULT = TCL_OK;
goto doLinkVars;
}
TRESULT = TCL_ERROR;
goto checkForCatch;
case INST_NSUPVAR:
TRACE_WITH_OBJ(("nsupvar "), OBJ_UNDER_TOS);
{
Tcl_Namespace *nsPtr, *savedNsPtr;
TRESULT = TclGetNamespaceFromObj(interp, OBJ_UNDER_TOS, &nsPtr);
if (TRESULT == TCL_OK) {
/*
* Locate the other variable.
*/
savedNsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr;
iPtr->varFramePtr->nsPtr = (Namespace *) nsPtr;
otherPtr = TclObjLookupVarEx(interp, OBJ_AT_TOS, NULL,
(TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "access",
/*createPart1*/ 1, /*createPart2*/ 1, &varPtr);
iPtr->varFramePtr->nsPtr = (Namespace *) savedNsPtr;
if (otherPtr) {
goto doLinkVars;
}
}
TRESULT = TCL_ERROR;
goto checkForCatch;
}
doLinkVars:
/*
* If we are here, the local variable has already been created: do the
* little work of TclPtrMakeUpvar that remains to be done right here
* if there are no errors; otherwise, let it handle the case.
*/
opnd = TclGetInt4AtPtr(pc+1);;
varPtr = LOCAL(opnd);
if ((varPtr != otherPtr) && !TclIsVarTraced(varPtr)
&& (TclIsVarUndefined(varPtr) || TclIsVarLink(varPtr))) {
if (!TclIsVarUndefined(varPtr)) {
/*
* Then it is a defined link.
*/
|
| ︙ | ︙ | |||
4000 4001 4002 4003 4004 4005 4006 |
}
TclSetVarLink(varPtr);
varPtr->value.linkPtr = otherPtr;
if (TclIsVarInHash(otherPtr)) {
VarHashRefCount(otherPtr)++;
}
} else {
| | | | 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 3988 3989 3990 |
}
TclSetVarLink(varPtr);
varPtr->value.linkPtr = otherPtr;
if (TclIsVarInHash(otherPtr)) {
VarHashRefCount(otherPtr)++;
}
} else {
TRESULT = TclPtrObjMakeUpvar(interp, otherPtr, NULL, 0, opnd);
if (TRESULT != TCL_OK) {
goto checkForCatch;
}
}
/*
* Do not pop the namespace or frame index, it may be needed for other
* variables - and [variable] did not push it at all.
|
| ︙ | ︙ | |||
4039 4040 4041 4042 4043 4044 4045 |
int jmpOffset[2], b;
Tcl_Obj *valuePtr;
/* TODO: consider rewrite so we don't compute the offset we're not
* going to take. */
case INST_JUMP_FALSE4:
jmpOffset[0] = TclGetInt4AtPtr(pc+1); /* FALSE offset */
| | | 4014 4015 4016 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 |
int jmpOffset[2], b;
Tcl_Obj *valuePtr;
/* TODO: consider rewrite so we don't compute the offset we're not
* going to take. */
case INST_JUMP_FALSE4:
jmpOffset[0] = TclGetInt4AtPtr(pc+1); /* FALSE offset */
jmpOffset[1] = 5; /* TRUE offset */
goto doCondJump;
case INST_JUMP_TRUE4:
jmpOffset[0] = 5;
jmpOffset[1] = TclGetInt4AtPtr(pc+1);
goto doCondJump;
|
| ︙ | ︙ | |||
4061 4062 4063 4064 4065 4066 4067 |
jmpOffset[1] = TclGetInt1AtPtr(pc+1);
doCondJump:
valuePtr = OBJ_AT_TOS;
/* TODO - check claim that taking address of b harms performance */
/* TODO - consider optimization search for constants */
| | | | 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 |
jmpOffset[1] = TclGetInt1AtPtr(pc+1);
doCondJump:
valuePtr = OBJ_AT_TOS;
/* TODO - check claim that taking address of b harms performance */
/* TODO - consider optimization search for constants */
TRESULT = TclGetBooleanFromObj(interp, valuePtr, &b);
if (TRESULT != TCL_OK) {
TRACE_WITH_OBJ(("%d => ERROR: ", jmpOffset[
((*pc == INST_JUMP_FALSE1) || (*pc == INST_JUMP_FALSE4))
? 0 : 1]), Tcl_GetObjResult(interp));
goto checkForCatch;
}
#ifdef TCL_COMPILE_DEBUG
|
| ︙ | ︙ | |||
4133 4134 4135 4136 4137 4138 4139 | * performed. */ int i1, i2, iResult; Tcl_Obj *value2Ptr = OBJ_AT_TOS; Tcl_Obj *valuePtr = OBJ_UNDER_TOS; | | | | | | | 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 |
* performed.
*/
int i1, i2, iResult;
Tcl_Obj *value2Ptr = OBJ_AT_TOS;
Tcl_Obj *valuePtr = OBJ_UNDER_TOS;
TRESULT = TclGetBooleanFromObj(NULL, valuePtr, &i1);
if (TRESULT != TCL_OK) {
TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr),
(valuePtr->typePtr? valuePtr->typePtr->name : "null")));
IllegalExprOperandType(interp, pc, valuePtr);
goto checkForCatch;
}
TRESULT = TclGetBooleanFromObj(NULL, value2Ptr, &i2);
if (TRESULT != TCL_OK) {
TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(value2Ptr),
(value2Ptr->typePtr? value2Ptr->typePtr->name : "null")));
IllegalExprOperandType(interp, pc, value2Ptr);
goto checkForCatch;
}
if (*pc == INST_LOR) {
iResult = (i1 || i2);
} else {
iResult = (i1 && i2);
}
objResultPtr = TCONST(iResult);
TRACE(("%.20s %.20s => %d\n", O2S(valuePtr),O2S(value2Ptr),iResult));
NEXT_INST_F(1, 2, 1);
}
/*
* ---------------------------------------------------------
* Start of INST_LIST and related instructions.
|
| ︙ | ︙ | |||
4184 4185 4186 4187 4188 4189 4190 |
case INST_LIST_LENGTH: {
Tcl_Obj *valuePtr;
int length;
valuePtr = OBJ_AT_TOS;
| | | | 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 |
case INST_LIST_LENGTH: {
Tcl_Obj *valuePtr;
int length;
valuePtr = OBJ_AT_TOS;
TRESULT = TclListObjLength(interp, valuePtr, &length);
if (TRESULT == TCL_OK) {
TclNewIntObj(objResultPtr, length);
TRACE(("%.20s => %d\n", O2S(valuePtr), length));
NEXT_INST_F(1, 1, 1);
} else {
TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(valuePtr)),
Tcl_GetObjResult(interp));
goto checkForCatch;
|
| ︙ | ︙ | |||
4216 4217 4218 4219 4220 4221 4222 | value2Ptr = OBJ_AT_TOS; valuePtr = OBJ_UNDER_TOS; /* * Extract the desired list element. */ | | | | | | | 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 4244 4245 4246 4247 4248 4249 4250 |
value2Ptr = OBJ_AT_TOS;
valuePtr = OBJ_UNDER_TOS;
/*
* Extract the desired list element.
*/
TRESULT = TclListObjGetElements(interp, valuePtr, &listc, &listv);
if ((TRESULT == TCL_OK) && (value2Ptr->typePtr != &tclListType)
&& (TclGetIntForIndexM(NULL , value2Ptr, listc-1,
&idx) == TCL_OK)) {
TclDecrRefCount(value2Ptr);
tosPtr--;
pcAdjustment = 1;
goto lindexFastPath;
}
objResultPtr = TclLindexList(interp, valuePtr, value2Ptr);
if (objResultPtr) {
/*
* Stash the list element on the stack.
*/
TRACE(("%.20s %.20s => %s\n",
O2S(valuePtr), O2S(value2Ptr), O2S(objResultPtr)));
NEXT_INST_F(1, 2, -1); /* Already has the correct refCount */
} else {
TRACE_WITH_OBJ(("%.30s %.30s => ERROR: ", O2S(valuePtr),
O2S(value2Ptr)), Tcl_GetObjResult(interp));
TRESULT = TCL_ERROR;
goto checkForCatch;
}
case INST_LIST_INDEX_IMM:
/*** lindex with objc==3 and index in bytecode stream ***/
pcAdjustment = 5;
/*
* Pop the list and get the index.
*/
valuePtr = OBJ_AT_TOS;
opnd = TclGetInt4AtPtr(pc+1);
/*
* Get the contents of the list, making sure that it really is a list
* in the process.
*/
TRESULT = TclListObjGetElements(interp, valuePtr, &listc, &listv);
if (TRESULT == TCL_OK) {
/*
* Select the list item based on the index. Negative operand means
* end-based indexing.
*/
if (opnd < -1) {
idx = opnd+1 + listc;
|
| ︙ | ︙ | |||
4322 4323 4324 4325 4326 4327 4328 |
* Set result.
*/
TRACE(("%d => %s\n", opnd, O2S(objResultPtr)));
NEXT_INST_V(5, opnd, -1);
} else {
TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp));
| | | 4297 4298 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 4309 4310 4311 |
* Set result.
*/
TRACE(("%d => %s\n", opnd, O2S(objResultPtr)));
NEXT_INST_V(5, opnd, -1);
} else {
TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp));
TRESULT = TCL_ERROR;
goto checkForCatch;
}
}
case INST_LSET_FLAT: {
/*
* Lset with 3, 5, or more args. Get the number of index args.
|
| ︙ | ︙ | |||
4374 4375 4376 4377 4378 4379 4380 |
* Set result.
*/
TRACE(("%d => %s\n", opnd, O2S(objResultPtr)));
NEXT_INST_V(5, (numIdx+1), -1);
} else {
TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp));
| | | 4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 |
* Set result.
*/
TRACE(("%d => %s\n", opnd, O2S(objResultPtr)));
NEXT_INST_V(5, (numIdx+1), -1);
} else {
TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp));
TRESULT = TCL_ERROR;
goto checkForCatch;
}
}
case INST_LSET_LIST: {
/*
* 'lset' with 4 args.
|
| ︙ | ︙ | |||
4423 4424 4425 4426 4427 4428 4429 |
*/
TRACE(("=> %s\n", O2S(objResultPtr)));
NEXT_INST_F(1, 2, -1);
} else {
TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(value2Ptr)),
Tcl_GetObjResult(interp));
| | | 4398 4399 4400 4401 4402 4403 4404 4405 4406 4407 4408 4409 4410 4411 4412 |
*/
TRACE(("=> %s\n", O2S(objResultPtr)));
NEXT_INST_F(1, 2, -1);
} else {
TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(value2Ptr)),
Tcl_GetObjResult(interp));
TRESULT = TCL_ERROR;
goto checkForCatch;
}
}
case INST_LIST_RANGE_IMM: {
/*** lrange with objc==4 and both indices in bytecode stream ***/
|
| ︙ | ︙ | |||
4446 4447 4448 4449 4450 4451 4452 | fromIdx = TclGetInt4AtPtr(pc+1); toIdx = TclGetInt4AtPtr(pc+5); /* * Get the contents of the list, making sure that it really is a list * in the process. */ | | | | 4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 |
fromIdx = TclGetInt4AtPtr(pc+1);
toIdx = TclGetInt4AtPtr(pc+5);
/*
* Get the contents of the list, making sure that it really is a list
* in the process.
*/
TRESULT = TclListObjGetElements(interp, valuePtr, &listc, &listv);
/*
* Skip a lot of work if we're about to throw the result away (common
* with uses of [lassign]).
*/
if (TRESULT == TCL_OK) {
#ifndef TCL_COMPILE_DEBUG
if (*(pc+9) == INST_POP) {
NEXT_INST_F(10, 1, 0);
}
#endif
} else {
TRACE_WITH_OBJ(("\"%.30s\" %d %d => ERROR: ", O2S(valuePtr),
|
| ︙ | ︙ | |||
4524 4525 4526 4527 4528 4529 4530 | const char *s2; value2Ptr = OBJ_AT_TOS; valuePtr = OBJ_UNDER_TOS; /* TODO: Consider more efficient tests than strcmp() */ s1 = TclGetStringFromObj(valuePtr, &s1len); | | | | 4499 4500 4501 4502 4503 4504 4505 4506 4507 4508 4509 4510 4511 4512 4513 4514 |
const char *s2;
value2Ptr = OBJ_AT_TOS;
valuePtr = OBJ_UNDER_TOS;
/* TODO: Consider more efficient tests than strcmp() */
s1 = TclGetStringFromObj(valuePtr, &s1len);
TRESULT = TclListObjLength(interp, value2Ptr, &llen);
if (TRESULT != TCL_OK) {
TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ERROR: ", O2S(valuePtr),
O2S(value2Ptr)), Tcl_GetObjResult(interp));
goto checkForCatch;
}
found = 0;
if (llen > 0) {
/*
|
| ︙ | ︙ | |||
4576 4577 4578 4579 4580 4581 4582 | NEXT_INST_F((found ? TclGetInt1AtPtr(pc+1) : 2), 2, 0); case INST_JUMP_FALSE4: NEXT_INST_F((found ? 5 : TclGetInt4AtPtr(pc+1)), 2, 0); case INST_JUMP_TRUE4: NEXT_INST_F((found ? TclGetInt4AtPtr(pc+1) : 5), 2, 0); } #endif | | | 4551 4552 4553 4554 4555 4556 4557 4558 4559 4560 4561 4562 4563 4564 4565 |
NEXT_INST_F((found ? TclGetInt1AtPtr(pc+1) : 2), 2, 0);
case INST_JUMP_FALSE4:
NEXT_INST_F((found ? 5 : TclGetInt4AtPtr(pc+1)), 2, 0);
case INST_JUMP_TRUE4:
NEXT_INST_F((found ? TclGetInt4AtPtr(pc+1) : 5), 2, 0);
}
#endif
objResultPtr = TCONST(found);
NEXT_INST_F(0, 2, 1);
}
/*
* End of INST_LIST and related instructions.
* ---------------------------------------------------------
*/
|
| ︙ | ︙ | |||
4647 4648 4649 4650 4651 4652 4653 | NEXT_INST_F((iResult? TclGetInt1AtPtr(pc+1) : 2), 2, 0); case INST_JUMP_FALSE4: NEXT_INST_F((iResult? 5 : TclGetInt4AtPtr(pc+1)), 2, 0); case INST_JUMP_TRUE4: NEXT_INST_F((iResult? TclGetInt4AtPtr(pc+1) : 5), 2, 0); } #endif | | | 4622 4623 4624 4625 4626 4627 4628 4629 4630 4631 4632 4633 4634 4635 4636 |
NEXT_INST_F((iResult? TclGetInt1AtPtr(pc+1) : 2), 2, 0);
case INST_JUMP_FALSE4:
NEXT_INST_F((iResult? 5 : TclGetInt4AtPtr(pc+1)), 2, 0);
case INST_JUMP_TRUE4:
NEXT_INST_F((iResult? TclGetInt4AtPtr(pc+1) : 5), 2, 0);
}
#endif
objResultPtr = TCONST(iResult);
NEXT_INST_F(0, 2, 1);
}
case INST_STR_CMP: {
/*
* String compare.
*/
|
| ︙ | ︙ | |||
4752 4753 4754 4755 4756 4757 4758 |
break;
}
}
if (iResult < 0) {
TclNewIntObj(objResultPtr, -1);
TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), -1));
} else {
| | | 4727 4728 4729 4730 4731 4732 4733 4734 4735 4736 4737 4738 4739 4740 4741 |
break;
}
}
if (iResult < 0) {
TclNewIntObj(objResultPtr, -1);
TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), -1));
} else {
objResultPtr = TCONST(iResult>0);
TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr),
(iResult > 0)));
}
NEXT_INST_F(1, 2, 1);
}
|
| ︙ | ︙ | |||
4787 4788 4789 4790 4791 4792 4793 | value2Ptr = OBJ_AT_TOS; valuePtr = OBJ_UNDER_TOS; /* * Get char length to calulate what 'end' means. */ length = Tcl_GetCharLength(valuePtr); | | | | 4762 4763 4764 4765 4766 4767 4768 4769 4770 4771 4772 4773 4774 4775 4776 4777 |
value2Ptr = OBJ_AT_TOS;
valuePtr = OBJ_UNDER_TOS;
/*
* Get char length to calulate what 'end' means.
*/
length = Tcl_GetCharLength(valuePtr);
TRESULT = TclGetIntForIndexM(interp, value2Ptr, length - 1, &index);
if (TRESULT != TCL_OK) {
goto checkForCatch;
}
if ((index >= 0) && (index < length)) {
if (TclIsPureByteArray(valuePtr)) {
objResultPtr = Tcl_NewByteArrayObj(
Tcl_GetByteArrayFromObj(valuePtr, &length)+index, 1);
|
| ︙ | ︙ | |||
4864 4865 4866 4867 4868 4869 4870 |
/*
* Reuse value2Ptr object already on stack if possible. Adjustment is
* 2 due to the nocase byte
* TODO: consider peephole opt.
*/
TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), match));
| | | 4839 4840 4841 4842 4843 4844 4845 4846 4847 4848 4849 4850 4851 4852 4853 |
/*
* Reuse value2Ptr object already on stack if possible. Adjustment is
* 2 due to the nocase byte
* TODO: consider peephole opt.
*/
TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), match));
objResultPtr = TCONST(match);
NEXT_INST_F(2, 2, 1);
}
case INST_REGEXP: {
int cflags, match;
Tcl_Obj *valuePtr, *value2Ptr;
Tcl_RegExp regExpr;
|
| ︙ | ︙ | |||
4892 4893 4894 4895 4896 4897 4898 |
* Adjustment is 2 due to the nocase byte
*/
if (match < 0) {
objResultPtr = Tcl_GetObjResult(interp);
TRACE_WITH_OBJ(("%.20s %.20s => ERROR: ",
O2S(valuePtr), O2S(value2Ptr)), objResultPtr);
| | | | 4867 4868 4869 4870 4871 4872 4873 4874 4875 4876 4877 4878 4879 4880 4881 4882 4883 4884 4885 4886 |
* Adjustment is 2 due to the nocase byte
*/
if (match < 0) {
objResultPtr = Tcl_GetObjResult(interp);
TRACE_WITH_OBJ(("%.20s %.20s => ERROR: ",
O2S(valuePtr), O2S(value2Ptr)), objResultPtr);
TRESULT = TCL_ERROR;
goto checkForCatch;
} else {
TRACE(("%.20s %.20s => %d\n",
O2S(valuePtr), O2S(value2Ptr), match));
objResultPtr = TCONST(match);
NEXT_INST_F(2, 2, 1);
}
}
case INST_EQ:
case INST_NEQ:
case INST_LT:
|
| ︙ | ︙ | |||
5215 5216 5217 5218 5219 5220 5221 | NEXT_INST_F((iResult? TclGetInt1AtPtr(pc+1) : 2), 2, 0); case INST_JUMP_FALSE4: NEXT_INST_F((iResult? 5 : TclGetInt4AtPtr(pc+1)), 2, 0); case INST_JUMP_TRUE4: NEXT_INST_F((iResult? TclGetInt4AtPtr(pc+1) : 5), 2, 0); } #endif | | | | | | | | | 5190 5191 5192 5193 5194 5195 5196 5197 5198 5199 5200 5201 5202 5203 5204 5205 5206 5207 5208 5209 5210 5211 5212 5213 5214 5215 5216 5217 5218 5219 5220 5221 5222 5223 5224 5225 5226 5227 5228 5229 5230 5231 |
NEXT_INST_F((iResult? TclGetInt1AtPtr(pc+1) : 2), 2, 0);
case INST_JUMP_FALSE4:
NEXT_INST_F((iResult? 5 : TclGetInt4AtPtr(pc+1)), 2, 0);
case INST_JUMP_TRUE4:
NEXT_INST_F((iResult? TclGetInt4AtPtr(pc+1) : 5), 2, 0);
}
#endif
objResultPtr = TCONST(iResult);
NEXT_INST_F(0, 2, 1);
}
case INST_MOD:
case INST_LSHIFT:
case INST_RSHIFT: {
Tcl_Obj *value2Ptr = OBJ_AT_TOS;
Tcl_Obj *valuePtr = OBJ_UNDER_TOS;
ClientData ptr1, ptr2;
int invalid, shift, type1, type2;
long l1 = 0;
TRESULT = GetNumberFromObj(NULL, valuePtr, &ptr1, &type1);
if ((TRESULT != TCL_OK) || (type1 == TCL_NUMBER_DOUBLE)
|| (type1 == TCL_NUMBER_NAN)) {
TRESULT = TCL_ERROR;
TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", O2S(valuePtr),
O2S(value2Ptr), (valuePtr->typePtr?
valuePtr->typePtr->name : "null")));
IllegalExprOperandType(interp, pc, valuePtr);
goto checkForCatch;
}
TRESULT = GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2);
if ((TRESULT != TCL_OK) || (type2 == TCL_NUMBER_DOUBLE)
|| (type2 == TCL_NUMBER_NAN)) {
TRESULT = TCL_ERROR;
TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", O2S(valuePtr),
O2S(value2Ptr), (value2Ptr->typePtr?
value2Ptr->typePtr->name : "null")));
IllegalExprOperandType(interp, pc, value2Ptr);
goto checkForCatch;
}
|
| ︙ | ︙ | |||
5267 5268 5269 5270 5271 5272 5273 |
goto divideByZero;
}
if ((l2 == 1) || (l2 == -1)) {
/*
* Div. by |1| always yields remainder of 0.
*/
| | | | 5242 5243 5244 5245 5246 5247 5248 5249 5250 5251 5252 5253 5254 5255 5256 5257 5258 5259 5260 5261 5262 5263 5264 5265 5266 5267 5268 |
goto divideByZero;
}
if ((l2 == 1) || (l2 == -1)) {
/*
* Div. by |1| always yields remainder of 0.
*/
objResultPtr = TCONST(0);
TRACE(("%s\n", O2S(objResultPtr)));
NEXT_INST_F(1, 2, 1);
}
}
if (type1 == TCL_NUMBER_LONG) {
l1 = *((const long *)ptr1);
if (l1 == 0) {
/*
* 0 % (non-zero) always yields remainder of 0.
*/
objResultPtr = TCONST(0);
TRACE(("%s\n", O2S(objResultPtr)));
NEXT_INST_F(1, 2, 1);
}
if (type2 == TCL_NUMBER_LONG) {
/*
* Both operands are long; do native calculation.
*/
|
| ︙ | ︙ | |||
5481 5482 5483 5484 5485 5486 5487 |
}
default:
/* Unused, here to silence compiler warning */
invalid = 0;
}
if (invalid) {
Tcl_SetResult(interp, "negative shift argument", TCL_STATIC);
| | | | 5456 5457 5458 5459 5460 5461 5462 5463 5464 5465 5466 5467 5468 5469 5470 5471 5472 5473 5474 5475 5476 5477 5478 5479 5480 |
}
default:
/* Unused, here to silence compiler warning */
invalid = 0;
}
if (invalid) {
Tcl_SetResult(interp, "negative shift argument", TCL_STATIC);
TRESULT = TCL_ERROR;
goto checkForCatch;
}
/*
* Zero shifted any number of bits is still zero.
*/
if ((type1==TCL_NUMBER_LONG) && (*((const long *)ptr1) == (long)0)) {
TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
objResultPtr = TCONST(0);
TRACE(("%s\n", O2S(objResultPtr)));
NEXT_INST_F(1, 2, 1);
}
if (*pc == INST_LSHIFT) {
/*
* Large left shifts create integer overflow.
|
| ︙ | ︙ | |||
5514 5515 5516 5517 5518 5519 5520 | /* * Technically, we could hold the value (1 << (INT_MAX+1)) in * an mp_int, but since we're using mp_mul_2d() to do the * work, and it takes only an int argument, that's a good * place to draw the line. */ | | > | | 5489 5490 5491 5492 5493 5494 5495 5496 5497 5498 5499 5500 5501 5502 5503 5504 5505 | /* * Technically, we could hold the value (1 << (INT_MAX+1)) in * an mp_int, but since we're using mp_mul_2d() to do the * work, and it takes only an int argument, that's a good * place to draw the line. */ Tcl_SetResult(interp, "integer value too large to represent", TCL_STATIC); TRESULT = TCL_ERROR; goto checkForCatch; } shift = (int)(*((const long *)ptr2)); /* * Handle shifts within the native long range. */ |
| ︙ | ︙ | |||
5592 5593 5594 5595 5596 5597 5598 |
break;
}
default:
/* Unused, here to silence compiler warning. */
zero = 0;
}
if (zero) {
| | | | | 5568 5569 5570 5571 5572 5573 5574 5575 5576 5577 5578 5579 5580 5581 5582 5583 5584 5585 5586 5587 5588 5589 5590 5591 5592 5593 5594 5595 5596 5597 5598 5599 5600 5601 5602 5603 5604 5605 5606 5607 5608 5609 5610 5611 5612 5613 5614 5615 5616 5617 5618 5619 5620 |
break;
}
default:
/* Unused, here to silence compiler warning. */
zero = 0;
}
if (zero) {
objResultPtr = TCONST(0);
} else {
TclNewIntObj(objResultPtr, -1);
}
TRACE(("%s\n", O2S(objResultPtr)));
NEXT_INST_F(1, 2, 1);
}
shift = (int)(*(const long *)ptr2);
/*
* Handle shifts within the native long range.
*/
if (type1 == TCL_NUMBER_LONG) {
l1 = *((const long *)ptr1);
if ((size_t)shift >= CHAR_BIT*sizeof(long)) {
if (l1 >= (long)0) {
objResultPtr = TCONST(0);
} else {
TclNewIntObj(objResultPtr, -1);
}
} else {
TclNewLongObj(objResultPtr, (l1 >> shift));
}
TRACE(("%s\n", O2S(objResultPtr)));
NEXT_INST_F(1, 2, 1);
}
#ifndef NO_WIDE_TYPE
/*
* Handle shifts within the native wide range.
*/
if (type1 == TCL_NUMBER_WIDE) {
Tcl_WideInt w = *(const Tcl_WideInt *)ptr1;
if ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideInt)) {
if (w >= (Tcl_WideInt)0) {
objResultPtr = TCONST(0);
} else {
TclNewIntObj(objResultPtr, -1);
}
} else {
objResultPtr = Tcl_NewWideIntObj(w >> shift);
}
TRACE(("%s\n", O2S(objResultPtr)));
|
| ︙ | ︙ | |||
5684 5685 5686 5687 5688 5689 5690 |
case INST_BITXOR:
case INST_BITAND: {
ClientData ptr1, ptr2;
int type1, type2;
Tcl_Obj *value2Ptr = OBJ_AT_TOS;
Tcl_Obj *valuePtr = OBJ_UNDER_TOS;
| | | | | | | | 5660 5661 5662 5663 5664 5665 5666 5667 5668 5669 5670 5671 5672 5673 5674 5675 5676 5677 5678 5679 5680 5681 5682 5683 5684 5685 5686 5687 5688 |
case INST_BITXOR:
case INST_BITAND: {
ClientData ptr1, ptr2;
int type1, type2;
Tcl_Obj *value2Ptr = OBJ_AT_TOS;
Tcl_Obj *valuePtr = OBJ_UNDER_TOS;
TRESULT = GetNumberFromObj(NULL, valuePtr, &ptr1, &type1);
if ((TRESULT != TCL_OK)
|| (type1 == TCL_NUMBER_NAN)
|| (type1 == TCL_NUMBER_DOUBLE)) {
TRESULT = TCL_ERROR;
TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", O2S(valuePtr),
O2S(value2Ptr), (valuePtr->typePtr?
valuePtr->typePtr->name : "null")));
IllegalExprOperandType(interp, pc, valuePtr);
goto checkForCatch;
}
TRESULT = GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2);
if ((TRESULT != TCL_OK) || (type2 == TCL_NUMBER_NAN)
|| (type2 == TCL_NUMBER_DOUBLE)) {
TRESULT = TCL_ERROR;
TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", O2S(valuePtr),
O2S(value2Ptr), (value2Ptr->typePtr?
value2Ptr->typePtr->name : "null")));
IllegalExprOperandType(interp, pc, value2Ptr);
goto checkForCatch;
}
|
| ︙ | ︙ | |||
5930 5931 5932 5933 5934 5935 5936 |
case INST_DIV:
case INST_MULT: {
ClientData ptr1, ptr2;
int type1, type2;
Tcl_Obj *value2Ptr = OBJ_AT_TOS;
Tcl_Obj *valuePtr = OBJ_UNDER_TOS;
| | | | | | | | 5906 5907 5908 5909 5910 5911 5912 5913 5914 5915 5916 5917 5918 5919 5920 5921 5922 5923 5924 5925 5926 5927 5928 5929 5930 5931 5932 5933 5934 5935 5936 5937 5938 5939 5940 5941 5942 5943 5944 5945 5946 5947 5948 5949 5950 |
case INST_DIV:
case INST_MULT: {
ClientData ptr1, ptr2;
int type1, type2;
Tcl_Obj *value2Ptr = OBJ_AT_TOS;
Tcl_Obj *valuePtr = OBJ_UNDER_TOS;
TRESULT = GetNumberFromObj(NULL, valuePtr, &ptr1, &type1);
if ((TRESULT != TCL_OK)
#ifndef ACCEPT_NAN
|| (type1 == TCL_NUMBER_NAN)
#endif
) {
TRESULT = TCL_ERROR;
TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n",
O2S(value2Ptr), O2S(valuePtr),
(valuePtr->typePtr? valuePtr->typePtr->name: "null")));
IllegalExprOperandType(interp, pc, valuePtr);
goto checkForCatch;
}
#ifdef ACCEPT_NAN
if (type1 == TCL_NUMBER_NAN) {
/*
* NaN first argument -> result is also NaN.
*/
NEXT_INST_F(1, 1, 0);
}
#endif
TRESULT = GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2);
if ((TRESULT != TCL_OK)
#ifndef ACCEPT_NAN
|| (type2 == TCL_NUMBER_NAN)
#endif
) {
TRESULT = TCL_ERROR;
TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n",
O2S(value2Ptr), O2S(valuePtr),
(value2Ptr->typePtr? value2Ptr->typePtr->name: "null")));
IllegalExprOperandType(interp, pc, value2Ptr);
goto checkForCatch;
}
|
| ︙ | ︙ | |||
6036 6037 6038 6039 6040 6041 6042 |
* Check now for IEEE floating-point error.
*/
if (TclIsNaN(dResult)) {
TRACE(("%.20s %.20s => IEEE FLOATING PT ERROR\n",
O2S(valuePtr), O2S(value2Ptr)));
TclExprFloatError(interp, dResult);
| | | 6012 6013 6014 6015 6016 6017 6018 6019 6020 6021 6022 6023 6024 6025 6026 |
* Check now for IEEE floating-point error.
*/
if (TclIsNaN(dResult)) {
TRACE(("%.20s %.20s => IEEE FLOATING PT ERROR\n",
O2S(valuePtr), O2S(value2Ptr)));
TclExprFloatError(interp, dResult);
TRESULT = TCL_ERROR;
goto checkForCatch;
}
#endif
TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
if (Tcl_IsShared(valuePtr)) {
TclNewDoubleObj(objResultPtr, dResult);
TRACE(("%s\n", O2S(objResultPtr)));
|
| ︙ | ︙ | |||
6106 6107 6108 6109 6110 6111 6112 |
if (type2 == TCL_NUMBER_LONG) {
l2 = *((const long *) ptr2);
if (l2 == 0) {
/*
* Anything to the zero power is 1.
*/
| | | 6082 6083 6084 6085 6086 6087 6088 6089 6090 6091 6092 6093 6094 6095 6096 |
if (type2 == TCL_NUMBER_LONG) {
l2 = *((const long *) ptr2);
if (l2 == 0) {
/*
* Anything to the zero power is 1.
*/
objResultPtr = TCONST(1);
NEXT_INST_F(1, 2, 1);
} else if (l2 == 1) {
/*
* Anything to the first power is itself
*/
NEXT_INST_F(1, 1, 0);
}
|
| ︙ | ︙ | |||
6161 6162 6163 6164 6165 6166 6167 |
TRACE(("%s %s => EXPONENT OF ZERO\n", O2S(valuePtr),
O2S(value2Ptr)));
goto exponOfZero;
case -1:
if (oddExponent) {
TclNewIntObj(objResultPtr, -1);
} else {
| | | | | | | > | | < | | | > | | 6137 6138 6139 6140 6141 6142 6143 6144 6145 6146 6147 6148 6149 6150 6151 6152 6153 6154 6155 6156 6157 6158 6159 6160 6161 6162 6163 6164 6165 6166 6167 6168 6169 6170 6171 6172 6173 6174 6175 6176 6177 6178 6179 6180 6181 6182 6183 6184 6185 6186 6187 6188 6189 6190 6191 6192 6193 6194 6195 6196 6197 6198 6199 6200 6201 6202 6203 6204 6205 6206 6207 6208 6209 6210 |
TRACE(("%s %s => EXPONENT OF ZERO\n", O2S(valuePtr),
O2S(value2Ptr)));
goto exponOfZero;
case -1:
if (oddExponent) {
TclNewIntObj(objResultPtr, -1);
} else {
objResultPtr = TCONST(1);
}
NEXT_INST_F(1, 2, 1);
case 1:
/*
* 1 to any power is 1.
*/
objResultPtr = TCONST(1);
NEXT_INST_F(1, 2, 1);
}
}
/*
* Integers with magnitude greater than 1 raise to a negative
* power yield the answer zero (see TIP 123).
*/
objResultPtr = TCONST(0);
NEXT_INST_F(1, 2, 1);
}
if (type1 == TCL_NUMBER_LONG) {
switch (l1) {
case 0:
/*
* Zero to a positive power is zero.
*/
objResultPtr = TCONST(0);
NEXT_INST_F(1, 2, 1);
case 1:
/*
* 1 to any power is 1.
*/
objResultPtr = TCONST(1);
NEXT_INST_F(1, 2, 1);
case -1:
if (oddExponent) {
TclNewIntObj(objResultPtr, -1);
} else {
objResultPtr = TCONST(1);
}
NEXT_INST_F(1, 2, 1);
}
}
/*
* We refuse to accept exponent arguments that exceed one mp_digit
* which means the max exponent value is 2**28-1 = 0x0fffffff =
* 268435455, which fits into a signed 32 bit int which is within
* the range of the long int type. This means any numeric Tcl_Obj
* value not using TCL_NUMBER_LONG type must hold a value larger
* than we accept.
*/
if (type2 != TCL_NUMBER_LONG) {
Tcl_SetResult(interp, "exponent too large", TCL_STATIC);
TRESULT = TCL_ERROR;
goto checkForCatch;
}
if (type1 == TCL_NUMBER_LONG) {
if (l1 == 2) {
/*
* Reduce small powers of 2 to shifts.
|
| ︙ | ︙ | |||
6369 6370 6371 6372 6373 6374 6375 |
#endif
}
#if (LONG_MAX > 0x7fffffff) || !defined(TCL_WIDE_INT_IS_LONG)
if (type1 == TCL_NUMBER_LONG) {
w1 = l1;
#ifndef NO_WIDE_TYPE
} else if (type1 == TCL_NUMBER_WIDE) {
| | | 6346 6347 6348 6349 6350 6351 6352 6353 6354 6355 6356 6357 6358 6359 6360 |
#endif
}
#if (LONG_MAX > 0x7fffffff) || !defined(TCL_WIDE_INT_IS_LONG)
if (type1 == TCL_NUMBER_LONG) {
w1 = l1;
#ifndef NO_WIDE_TYPE
} else if (type1 == TCL_NUMBER_WIDE) {
w1 = *((const Tcl_WideInt *) ptr1);
#endif
} else {
goto overflow;
}
if (l2 - 2 < (long)MaxBase64Size
&& w1 <= MaxBase64[l2 - 2]
&& w1 >= -MaxBase64[l2 - 2]) {
|
| ︙ | ︙ | |||
6454 6455 6456 6457 6458 6459 6460 | wResult *= w1; /* b**15 */ break; case 16: wResult *= wResult; /* b**4 */ wResult *= wResult; /* b**8 */ wResult *= wResult; /* b**16 */ break; | < > | 6431 6432 6433 6434 6435 6436 6437 6438 6439 6440 6441 6442 6443 6444 6445 6446 6447 6448 6449 6450 6451 6452 6453 6454 6455 6456 |
wResult *= w1; /* b**15 */
break;
case 16:
wResult *= wResult; /* b**4 */
wResult *= wResult; /* b**8 */
wResult *= wResult; /* b**16 */
break;
}
TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
objResultPtr = Tcl_NewWideIntObj(wResult);
TRACE(("%s\n", O2S(objResultPtr)));
NEXT_INST_F(1, 2, 1);
}
/*
* Handle cases of powers > 16 that still fit in a 64-bit word by
* doing table lookup.
*/
if (w1 - 3 >= 0 && w1 - 2 < (long)Exp64IndexSize
&& l2 - 2 < (long)(Exp64ValueSize + MaxBase64Size)) {
unsigned short base = Exp64Index[w1 - 3]
+ (unsigned short) (l2 - 2 - MaxBase64Size);
if (base < Exp64Index[w1 - 2]) {
/*
|
| ︙ | ︙ | |||
6658 6659 6660 6661 6662 6663 6664 |
break;
case INST_EXPON:
if (big2.used > 1) {
Tcl_SetResult(interp, "exponent too large", TCL_STATIC);
mp_clear(&big1);
mp_clear(&big2);
mp_clear(&bigResult);
| | | 6635 6636 6637 6638 6639 6640 6641 6642 6643 6644 6645 6646 6647 6648 6649 |
break;
case INST_EXPON:
if (big2.used > 1) {
Tcl_SetResult(interp, "exponent too large", TCL_STATIC);
mp_clear(&big1);
mp_clear(&big2);
mp_clear(&bigResult);
TRESULT = TCL_ERROR;
goto checkForCatch;
}
mp_expt_d(&big1, big2.dp[0], &bigResult);
break;
}
mp_clear(&big1);
mp_clear(&big2);
|
| ︙ | ︙ | |||
6683 6684 6685 6686 6687 6688 6689 |
case INST_LNOT: {
int b;
Tcl_Obj *valuePtr = OBJ_AT_TOS;
/* TODO - check claim that taking address of b harms performance */
/* TODO - consider optimization search for constants */
| | | | | | | | 6660 6661 6662 6663 6664 6665 6666 6667 6668 6669 6670 6671 6672 6673 6674 6675 6676 6677 6678 6679 6680 6681 6682 6683 6684 6685 6686 6687 6688 6689 6690 6691 6692 6693 6694 6695 6696 6697 6698 6699 |
case INST_LNOT: {
int b;
Tcl_Obj *valuePtr = OBJ_AT_TOS;
/* TODO - check claim that taking address of b harms performance */
/* TODO - consider optimization search for constants */
TRESULT = TclGetBooleanFromObj(NULL, valuePtr, &b);
if (TRESULT != TCL_OK) {
TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n", O2S(valuePtr),
(valuePtr->typePtr? valuePtr->typePtr->name : "null")));
IllegalExprOperandType(interp, pc, valuePtr);
goto checkForCatch;
}
/* TODO: Consider peephole opt. */
objResultPtr = TCONST(!b);
NEXT_INST_F(1, 1, 1);
}
case INST_BITNOT: {
mp_int big;
ClientData ptr;
int type;
Tcl_Obj *valuePtr = OBJ_AT_TOS;
TRESULT = GetNumberFromObj(NULL, valuePtr, &ptr, &type);
if ((TRESULT != TCL_OK)
|| (type == TCL_NUMBER_NAN) || (type == TCL_NUMBER_DOUBLE)) {
/*
* ... ~$NonInteger => raise an error.
*/
TRESULT = TCL_ERROR;
TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr),
(valuePtr->typePtr? valuePtr->typePtr->name : "null")));
IllegalExprOperandType(interp, pc, valuePtr);
goto checkForCatch;
}
if (type == TCL_NUMBER_LONG) {
long l = *((const long *)ptr);
|
| ︙ | ︙ | |||
6753 6754 6755 6756 6757 6758 6759 |
}
case INST_UMINUS: {
ClientData ptr;
int type;
Tcl_Obj *valuePtr = OBJ_AT_TOS;
| | | | | 6730 6731 6732 6733 6734 6735 6736 6737 6738 6739 6740 6741 6742 6743 6744 6745 6746 6747 6748 6749 6750 |
}
case INST_UMINUS: {
ClientData ptr;
int type;
Tcl_Obj *valuePtr = OBJ_AT_TOS;
TRESULT = GetNumberFromObj(NULL, valuePtr, &ptr, &type);
if ((TRESULT != TCL_OK)
#ifndef ACCEPT_NAN
|| (type == TCL_NUMBER_NAN)
#endif
) {
TRESULT = TCL_ERROR;
TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr),
(valuePtr->typePtr? valuePtr->typePtr->name : "null")));
IllegalExprOperandType(interp, pc, valuePtr);
goto checkForCatch;
}
switch (type) {
case TCL_NUMBER_DOUBLE: {
|
| ︙ | ︙ | |||
6858 6859 6860 6861 6862 6863 6864 |
if (GetNumberFromObj(NULL, valuePtr, &ptr, &type) != TCL_OK) {
if (*pc == INST_UPLUS) {
/*
* ... +$NonNumeric => raise an error.
*/
| | | | 6835 6836 6837 6838 6839 6840 6841 6842 6843 6844 6845 6846 6847 6848 6849 6850 6851 6852 6853 6854 6855 6856 6857 6858 6859 6860 6861 6862 |
if (GetNumberFromObj(NULL, valuePtr, &ptr, &type) != TCL_OK) {
if (*pc == INST_UPLUS) {
/*
* ... +$NonNumeric => raise an error.
*/
TRESULT = TCL_ERROR;
TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr),
(valuePtr->typePtr? valuePtr->typePtr->name:"null")));
IllegalExprOperandType(interp, pc, valuePtr);
goto checkForCatch;
} else {
/* ... TryConvertToNumeric($NonNumeric) is acceptable */
TRACE(("\"%.20s\" => not numeric\n", O2S(valuePtr)));
NEXT_INST_F(1, 0, 0);
}
}
#ifndef ACCEPT_NAN
if (type == TCL_NUMBER_NAN) {
TRESULT = TCL_ERROR;
if (*pc == INST_UPLUS) {
/*
* ... +$NonNumeric => raise an error.
*/
TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr),
(valuePtr->typePtr? valuePtr->typePtr->name:"null")));
|
| ︙ | ︙ | |||
6932 6933 6934 6935 6936 6937 6938 |
case INST_BREAK:
/*
DECACHE_STACK_INFO();
Tcl_ResetResult(interp);
CACHE_STACK_INFO();
*/
| | | | | 6909 6910 6911 6912 6913 6914 6915 6916 6917 6918 6919 6920 6921 6922 6923 6924 6925 6926 6927 6928 6929 6930 6931 6932 6933 6934 6935 6936 6937 6938 6939 6940 6941 6942 6943 6944 6945 6946 6947 6948 6949 6950 6951 |
case INST_BREAK:
/*
DECACHE_STACK_INFO();
Tcl_ResetResult(interp);
CACHE_STACK_INFO();
*/
TRESULT = TCL_BREAK;
cleanup = 0;
goto processExceptionReturn;
case INST_CONTINUE:
/*
DECACHE_STACK_INFO();
Tcl_ResetResult(interp);
CACHE_STACK_INFO();
*/
TRESULT = TCL_CONTINUE;
cleanup = 0;
goto processExceptionReturn;
case INST_FOREACH_START4: {
/*
* Initialize the temporary local var that holds the count of the
* number of iterations of the loop body to -1.
*/
int opnd, iterTmpIndex;
ForeachInfo *infoPtr;
Var *iterVarPtr;
Tcl_Obj *oldValuePtr;
opnd = TclGetUInt4AtPtr(pc+1);
infoPtr = (ForeachInfo *) codePtr->auxDataArrayPtr[opnd].clientData;
iterTmpIndex = infoPtr->loopCtTemp;
iterVarPtr = LOCAL(iterTmpIndex);
oldValuePtr = iterVarPtr->value.objPtr;
if (oldValuePtr == NULL) {
TclNewLongObj(iterVarPtr->value.objPtr, -1);
Tcl_IncrRefCount(iterVarPtr->value.objPtr);
} else {
TclSetLongObj(oldValuePtr, -1);
|
| ︙ | ︙ | |||
7007 7008 7009 7010 7011 7012 7013 | infoPtr = (ForeachInfo *) codePtr->auxDataArrayPtr[opnd].clientData; numLists = infoPtr->numLists; /* * Increment the temp holding the loop iteration number. */ | | | | | | 6984 6985 6986 6987 6988 6989 6990 6991 6992 6993 6994 6995 6996 6997 6998 6999 7000 7001 7002 7003 7004 7005 7006 7007 7008 7009 7010 7011 7012 7013 7014 7015 7016 7017 |
infoPtr = (ForeachInfo *) codePtr->auxDataArrayPtr[opnd].clientData;
numLists = infoPtr->numLists;
/*
* Increment the temp holding the loop iteration number.
*/
iterVarPtr = LOCAL(infoPtr->loopCtTemp);
valuePtr = iterVarPtr->value.objPtr;
iterNum = (valuePtr->internalRep.longValue + 1);
TclSetLongObj(valuePtr, iterNum);
/*
* Check whether all value lists are exhausted and we should stop the
* loop.
*/
continueLoop = 0;
listTmpIndex = infoPtr->firstValueTemp;
for (i = 0; i < numLists; i++) {
varListPtr = infoPtr->varLists[i];
numVars = varListPtr->numVars;
listVarPtr = LOCAL(listTmpIndex);
listPtr = listVarPtr->value.objPtr;
TRESULT = TclListObjLength(interp, listPtr, &listLen);
if (TRESULT == TCL_OK) {
if (listLen > (iterNum * numVars)) {
continueLoop = 1;
}
listTmpIndex++;
} else {
TRACE_WITH_OBJ(("%u => ERROR converting list %ld, \"%s\": ",
opnd, i, O2S(listPtr)), Tcl_GetObjResult(interp));
|
| ︙ | ︙ | |||
7053 7054 7055 7056 7057 7058 7059 |
if (continueLoop) {
listTmpIndex = infoPtr->firstValueTemp;
for (i = 0; i < numLists; i++) {
varListPtr = infoPtr->varLists[i];
numVars = varListPtr->numVars;
| | | | 7030 7031 7032 7033 7034 7035 7036 7037 7038 7039 7040 7041 7042 7043 7044 7045 7046 7047 7048 7049 7050 7051 7052 7053 7054 7055 7056 7057 |
if (continueLoop) {
listTmpIndex = infoPtr->firstValueTemp;
for (i = 0; i < numLists; i++) {
varListPtr = infoPtr->varLists[i];
numVars = varListPtr->numVars;
listVarPtr = LOCAL(listTmpIndex);
listPtr = TclListObjCopy(NULL, listVarPtr->value.objPtr);
TclListObjGetElements(interp, listPtr, &listLen, &elements);
valIndex = (iterNum * numVars);
for (j = 0; j < numVars; j++) {
if (valIndex >= listLen) {
TclNewObj(valuePtr);
} else {
valuePtr = elements[valIndex];
}
varIndex = varListPtr->varIndexes[j];
varPtr = LOCAL(varIndex);
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
if (TclIsVarDirectWritable(varPtr)) {
value2Ptr = varPtr->value.objPtr;
if (valuePtr != value2Ptr) {
if (value2Ptr != NULL) {
|
| ︙ | ︙ | |||
7088 7089 7090 7091 7092 7093 7094 |
value2Ptr = TclPtrSetVar(interp, varPtr, NULL, NULL,
NULL, valuePtr, TCL_LEAVE_ERR_MSG, varIndex);
CACHE_STACK_INFO();
if (value2Ptr == NULL) {
TRACE_WITH_OBJ((
"%u => ERROR init. index temp %d: ",
opnd,varIndex), Tcl_GetObjResult(interp));
| | | 7065 7066 7067 7068 7069 7070 7071 7072 7073 7074 7075 7076 7077 7078 7079 |
value2Ptr = TclPtrSetVar(interp, varPtr, NULL, NULL,
NULL, valuePtr, TCL_LEAVE_ERR_MSG, varIndex);
CACHE_STACK_INFO();
if (value2Ptr == NULL) {
TRACE_WITH_OBJ((
"%u => ERROR init. index temp %d: ",
opnd,varIndex), Tcl_GetObjResult(interp));
TRESULT = TCL_ERROR;
TclDecrRefCount(listPtr);
goto checkForCatch;
}
}
valIndex++;
}
TclDecrRefCount(listPtr);
|
| ︙ | ︙ | |||
7132 7133 7134 7135 7136 7137 7138 |
TclGetUInt4AtPtr(pc+1), (int) (catchTop - initCatchTop - 1),
(int) CURR_DEPTH));
NEXT_INST_F(5, 0, 0);
case INST_END_CATCH:
catchTop--;
Tcl_ResetResult(interp);
| | | 7109 7110 7111 7112 7113 7114 7115 7116 7117 7118 7119 7120 7121 7122 7123 |
TclGetUInt4AtPtr(pc+1), (int) (catchTop - initCatchTop - 1),
(int) CURR_DEPTH));
NEXT_INST_F(5, 0, 0);
case INST_END_CATCH:
catchTop--;
Tcl_ResetResult(interp);
TRESULT = TCL_OK;
TRACE(("=> catchTop=%d\n", (int) (catchTop - initCatchTop - 1)));
NEXT_INST_F(1, 0, 0);
case INST_PUSH_RESULT:
objResultPtr = Tcl_GetObjResult(interp);
TRACE_WITH_OBJ(("=> "), objResultPtr);
|
| ︙ | ︙ | |||
7154 7155 7156 7157 7158 7159 7160 |
Tcl_IncrRefCount(newObjResultPtr);
iPtr->objResultPtr = newObjResultPtr;
}
NEXT_INST_F(1, 0, -1);
case INST_PUSH_RETURN_CODE:
| | | | < | | | | | | | | 7131 7132 7133 7134 7135 7136 7137 7138 7139 7140 7141 7142 7143 7144 7145 7146 7147 7148 7149 7150 7151 7152 7153 7154 7155 7156 7157 7158 7159 7160 7161 7162 7163 7164 7165 7166 7167 7168 7169 7170 7171 7172 7173 7174 7175 7176 7177 7178 7179 7180 7181 7182 7183 7184 7185 7186 7187 7188 7189 7190 7191 7192 7193 7194 7195 7196 7197 7198 7199 7200 7201 7202 7203 7204 7205 7206 7207 7208 7209 7210 7211 7212 7213 7214 |
Tcl_IncrRefCount(newObjResultPtr);
iPtr->objResultPtr = newObjResultPtr;
}
NEXT_INST_F(1, 0, -1);
case INST_PUSH_RETURN_CODE:
TclNewIntObj(objResultPtr, TRESULT);
TRACE(("=> %u\n", TRESULT));
NEXT_INST_F(1, 0, 1);
case INST_PUSH_RETURN_OPTIONS:
objResultPtr = Tcl_GetReturnOptions(interp, TRESULT);
TRACE_WITH_OBJ(("=> "), objResultPtr);
NEXT_INST_F(1, 0, 1);
case INST_RETURN_CODE_BRANCH: {
int code;
if (TclGetIntFromObj(NULL, OBJ_AT_TOS, &code) != TCL_OK) {
Tcl_Panic("INST_RETURN_CODE_BRANCH: TOS not a return code!");
}
if (code == TCL_OK) {
Tcl_Panic("INST_RETURN_CODE_BRANCH: TOS is TCL_OK!");
}
if (code < TCL_ERROR || code > TCL_CONTINUE) {
code = TCL_CONTINUE + 1;
}
NEXT_INST_F(2*code -1, 1, 0);
}
{
int opnd, opnd2, allocateDict;
Tcl_Obj *dictPtr, *valuePtr, *val2Ptr;
Var *varPtr;
case INST_DICT_GET:
opnd = TclGetUInt4AtPtr(pc+1);
TRACE(("%u => ", opnd));
dictPtr = OBJ_AT_DEPTH(opnd);
if (opnd > 1) {
dictPtr = TclTraceDictPath(interp, dictPtr, opnd-1,
&OBJ_AT_DEPTH(opnd-1), DICT_PATH_READ);
if (dictPtr == NULL) {
TRACE_WITH_OBJ((
"%u => ERROR tracing dictionary path into \"%s\": ",
opnd, O2S(OBJ_AT_DEPTH(opnd))),
Tcl_GetObjResult(interp));
TRESULT = TCL_ERROR;
goto checkForCatch;
}
}
TRESULT = Tcl_DictObjGet(interp, dictPtr, OBJ_AT_TOS, &objResultPtr);
if ((TRESULT == TCL_OK) && objResultPtr) {
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
NEXT_INST_V(5, opnd+1, 1);
}
if (TRESULT != TCL_OK) {
TRACE_WITH_OBJ((
"%u => ERROR reading leaf dictionary key \"%s\": ",
opnd, O2S(dictPtr)), Tcl_GetObjResult(interp));
} else {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "key \"", TclGetString(OBJ_AT_TOS),
"\" not known in dictionary", NULL);
TRACE_WITH_OBJ(("%u => ERROR ", opnd), Tcl_GetObjResult(interp));
TRESULT = TCL_ERROR;
}
goto checkForCatch;
case INST_DICT_SET:
case INST_DICT_UNSET:
case INST_DICT_INCR_IMM:
opnd = TclGetUInt4AtPtr(pc+1);
opnd2 = TclGetUInt4AtPtr(pc+5);
varPtr = LOCAL(opnd2);
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
TRACE(("%u %u => ", opnd, opnd2));
if (TclIsVarDirectReadable(varPtr)) {
dictPtr = varPtr->value.objPtr;
} else {
|
| ︙ | ︙ | |||
7249 7250 7251 7252 7253 7254 7255 |
dictPtr = Tcl_DuplicateObj(dictPtr);
}
}
switch (*pc) {
case INST_DICT_SET:
cleanup = opnd + 1;
| | | | | | < | | | | | | | | | | < | | | | | 7225 7226 7227 7228 7229 7230 7231 7232 7233 7234 7235 7236 7237 7238 7239 7240 7241 7242 7243 7244 7245 7246 7247 7248 7249 7250 7251 7252 7253 7254 7255 7256 7257 7258 7259 7260 7261 7262 7263 7264 7265 7266 7267 7268 7269 7270 7271 7272 7273 7274 7275 7276 7277 7278 7279 7280 7281 7282 7283 7284 7285 7286 7287 7288 7289 7290 7291 7292 7293 7294 7295 7296 7297 7298 7299 7300 7301 7302 7303 7304 7305 7306 7307 7308 7309 7310 7311 7312 7313 7314 7315 7316 7317 7318 7319 7320 |
dictPtr = Tcl_DuplicateObj(dictPtr);
}
}
switch (*pc) {
case INST_DICT_SET:
cleanup = opnd + 1;
TRESULT = Tcl_DictObjPutKeyList(interp, dictPtr, opnd,
&OBJ_AT_DEPTH(opnd), OBJ_AT_TOS);
break;
case INST_DICT_INCR_IMM:
cleanup = 1;
opnd = TclGetInt4AtPtr(pc+1);
TRESULT = Tcl_DictObjGet(interp, dictPtr, OBJ_AT_TOS, &valuePtr);
if (TRESULT != TCL_OK) {
break;
}
if (valuePtr == NULL) {
Tcl_DictObjPut(NULL, dictPtr, OBJ_AT_TOS,Tcl_NewIntObj(opnd));
} else {
val2Ptr = Tcl_NewIntObj(opnd);
Tcl_IncrRefCount(val2Ptr);
if (Tcl_IsShared(valuePtr)) {
valuePtr = Tcl_DuplicateObj(valuePtr);
Tcl_DictObjPut(NULL, dictPtr, OBJ_AT_TOS, valuePtr);
}
TRESULT = TclIncrObj(interp, valuePtr, val2Ptr);
if (TRESULT == TCL_OK) {
Tcl_InvalidateStringRep(dictPtr);
}
TclDecrRefCount(val2Ptr);
}
break;
case INST_DICT_UNSET:
cleanup = opnd;
TRESULT = Tcl_DictObjRemoveKeyList(interp, dictPtr, opnd,
&OBJ_AT_DEPTH(opnd-1));
break;
default:
cleanup = 0; /* stop compiler warning */
Tcl_Panic("Should not happen!");
}
if (TRESULT != TCL_OK) {
if (allocateDict) {
TclDecrRefCount(dictPtr);
}
TRACE_WITH_OBJ(("%u %u => ERROR updating dictionary: ",
opnd, opnd2), Tcl_GetObjResult(interp));
goto checkForCatch;
}
if (TclIsVarDirectWritable(varPtr)) {
if (allocateDict) {
val2Ptr = varPtr->value.objPtr;
Tcl_IncrRefCount(dictPtr);
if (val2Ptr != NULL) {
TclDecrRefCount(val2Ptr);
}
varPtr->value.objPtr = dictPtr;
}
objResultPtr = dictPtr;
} else {
Tcl_IncrRefCount(dictPtr);
DECACHE_STACK_INFO();
objResultPtr = TclPtrSetVar(interp, varPtr, NULL, NULL, NULL,
dictPtr, TCL_LEAVE_ERR_MSG, opnd2);
CACHE_STACK_INFO();
TclDecrRefCount(dictPtr);
if (objResultPtr == NULL) {
TRACE_APPEND(("ERROR: %.30s\n",
O2S(Tcl_GetObjResult(interp))));
TRESULT = TCL_ERROR;
goto checkForCatch;
}
}
#ifndef TCL_COMPILE_DEBUG
if (*(pc+9) == INST_POP) {
NEXT_INST_V(10, cleanup, 0);
}
#endif
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
NEXT_INST_V(9, cleanup, 1);
case INST_DICT_APPEND:
case INST_DICT_LAPPEND:
opnd = TclGetUInt4AtPtr(pc+1);
varPtr = LOCAL(opnd);
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
TRACE(("%u => ", opnd));
if (TclIsVarDirectReadable(varPtr)) {
dictPtr = varPtr->value.objPtr;
} else {
|
| ︙ | ︙ | |||
7354 7355 7356 7357 7358 7359 7360 |
} else {
allocateDict = Tcl_IsShared(dictPtr);
if (allocateDict) {
dictPtr = Tcl_DuplicateObj(dictPtr);
}
}
| | | | | | | | | | | | | | > | | | > | | | < | | | | 7328 7329 7330 7331 7332 7333 7334 7335 7336 7337 7338 7339 7340 7341 7342 7343 7344 7345 7346 7347 7348 7349 7350 7351 7352 7353 7354 7355 7356 7357 7358 7359 7360 7361 7362 7363 7364 7365 7366 7367 7368 7369 7370 7371 7372 7373 7374 7375 7376 7377 7378 7379 7380 7381 7382 7383 7384 7385 7386 7387 7388 7389 7390 7391 7392 7393 7394 7395 7396 7397 7398 7399 7400 7401 7402 7403 7404 7405 7406 7407 7408 7409 7410 7411 7412 7413 7414 7415 7416 7417 7418 7419 7420 7421 7422 |
} else {
allocateDict = Tcl_IsShared(dictPtr);
if (allocateDict) {
dictPtr = Tcl_DuplicateObj(dictPtr);
}
}
TRESULT = Tcl_DictObjGet(interp, dictPtr, OBJ_UNDER_TOS, &valuePtr);
if (TRESULT != TCL_OK) {
if (allocateDict) {
TclDecrRefCount(dictPtr);
}
goto checkForCatch;
}
/*
* Note that a non-existent key results in a NULL valuePtr, which is a
* case handled separately below. What we *can* say at this point is
* that the write-back will always succeed.
*/
switch (*pc) {
case INST_DICT_APPEND:
if (valuePtr == NULL) {
valuePtr = OBJ_AT_TOS;
} else {
if (Tcl_IsShared(valuePtr)) {
valuePtr = Tcl_DuplicateObj(valuePtr);
}
Tcl_AppendObjToObj(valuePtr, OBJ_AT_TOS);
}
break;
case INST_DICT_LAPPEND:
/*
* More complex because list-append can fail.
*/
if (valuePtr == NULL) {
valuePtr = Tcl_NewListObj(1, &OBJ_AT_TOS);
} else if (Tcl_IsShared(valuePtr)) {
valuePtr = Tcl_DuplicateObj(valuePtr);
TRESULT = Tcl_ListObjAppendElement(interp, valuePtr,
OBJ_AT_TOS);
if (TRESULT != TCL_OK) {
TclDecrRefCount(valuePtr);
if (allocateDict) {
TclDecrRefCount(dictPtr);
}
goto checkForCatch;
}
} else {
TRESULT = Tcl_ListObjAppendElement(interp, valuePtr,
OBJ_AT_TOS);
if (TRESULT != TCL_OK) {
if (allocateDict) {
TclDecrRefCount(dictPtr);
}
goto checkForCatch;
}
}
break;
default:
Tcl_Panic("Should not happen!");
}
Tcl_DictObjPut(NULL, dictPtr, OBJ_UNDER_TOS, valuePtr);
if (TclIsVarDirectWritable(varPtr)) {
if (allocateDict) {
val2Ptr = varPtr->value.objPtr;
Tcl_IncrRefCount(dictPtr);
if (val2Ptr != NULL) {
TclDecrRefCount(val2Ptr);
}
varPtr->value.objPtr = dictPtr;
}
objResultPtr = dictPtr;
} else {
Tcl_IncrRefCount(dictPtr);
DECACHE_STACK_INFO();
objResultPtr = TclPtrSetVar(interp, varPtr, NULL, NULL, NULL,
dictPtr, TCL_LEAVE_ERR_MSG, opnd);
CACHE_STACK_INFO();
TclDecrRefCount(dictPtr);
if (objResultPtr == NULL) {
TRACE_APPEND(("ERROR: %.30s\n",
O2S(Tcl_GetObjResult(interp))));
TRESULT = TCL_ERROR;
goto checkForCatch;
}
}
#ifndef TCL_COMPILE_DEBUG
if (*(pc+5) == INST_POP) {
NEXT_INST_F(6, 2, 0);
}
|
| ︙ | ︙ | |||
7457 7458 7459 7460 7461 7462 7463 |
Tcl_DictSearch *searchPtr;
case INST_DICT_FIRST:
opnd = TclGetUInt4AtPtr(pc+1);
TRACE(("%u => ", opnd));
dictPtr = POP_OBJECT();
searchPtr = (Tcl_DictSearch *) ckalloc(sizeof(Tcl_DictSearch));
| | | | | | | | | | < | | | | | | 7432 7433 7434 7435 7436 7437 7438 7439 7440 7441 7442 7443 7444 7445 7446 7447 7448 7449 7450 7451 7452 7453 7454 7455 7456 7457 7458 7459 7460 7461 7462 7463 7464 7465 7466 7467 7468 7469 7470 7471 7472 7473 7474 7475 7476 7477 7478 7479 7480 7481 7482 7483 7484 7485 7486 7487 7488 7489 7490 7491 7492 7493 7494 7495 7496 7497 7498 7499 7500 7501 7502 7503 7504 7505 7506 7507 7508 7509 7510 7511 7512 7513 7514 7515 7516 7517 7518 7519 7520 7521 7522 7523 7524 7525 7526 7527 7528 7529 7530 7531 7532 7533 7534 7535 |
Tcl_DictSearch *searchPtr;
case INST_DICT_FIRST:
opnd = TclGetUInt4AtPtr(pc+1);
TRACE(("%u => ", opnd));
dictPtr = POP_OBJECT();
searchPtr = (Tcl_DictSearch *) ckalloc(sizeof(Tcl_DictSearch));
TRESULT = Tcl_DictObjFirst(interp, dictPtr, searchPtr, &keyPtr,
&valuePtr, &done);
if (TRESULT != TCL_OK) {
ckfree((char *) searchPtr);
goto checkForCatch;
}
TclNewObj(statePtr);
statePtr->typePtr = &dictIteratorType;
statePtr->internalRep.twoPtrValue.ptr1 = searchPtr;
statePtr->internalRep.twoPtrValue.ptr2 = dictPtr;
varPtr = LOCAL(opnd);//
if (varPtr->value.objPtr) {
if (varPtr->value.objPtr->typePtr != &dictIteratorType) {
TclDecrRefCount(varPtr->value.objPtr);
} else {
Tcl_Panic("mis-issued dictFirst!");
}
}
varPtr->value.objPtr = statePtr;
Tcl_IncrRefCount(statePtr);
goto pushDictIteratorResult;
case INST_DICT_NEXT:
opnd = TclGetUInt4AtPtr(pc+1);
TRACE(("%u => ", opnd));
statePtr = (*LOCAL(opnd)).value.objPtr;
if (statePtr == NULL || statePtr->typePtr != &dictIteratorType) {
Tcl_Panic("mis-issued dictNext!");
}
searchPtr = statePtr->internalRep.twoPtrValue.ptr1;
Tcl_DictObjNext(searchPtr, &keyPtr, &valuePtr, &done);
pushDictIteratorResult:
if (done) {
TclNewObj(emptyPtr);
PUSH_OBJECT(emptyPtr);
PUSH_OBJECT(emptyPtr);
} else {
PUSH_OBJECT(valuePtr);
PUSH_OBJECT(keyPtr);
}
TRACE_APPEND(("\"%.30s\" \"%.30s\" %d",
O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), done));
objResultPtr = TCONST(done);
/* TODO: consider opt like INST_FOREACH_STEP4 */
NEXT_INST_F(5, 0, 1);
case INST_DICT_DONE:
opnd = TclGetUInt4AtPtr(pc+1);
TRACE(("%u => ", opnd));
statePtr = (*LOCAL(opnd)).value.objPtr;
if (statePtr == NULL) {
Tcl_Panic("mis-issued dictDone!");
}
if (statePtr->typePtr == &dictIteratorType) {
/*
* First kill the search, and then release the reference to the
* dictionary that we were holding.
*/
searchPtr = statePtr->internalRep.twoPtrValue.ptr1;
Tcl_DictObjDone(searchPtr);
ckfree((char *) searchPtr);
dictPtr = statePtr->internalRep.twoPtrValue.ptr2;
TclDecrRefCount(dictPtr);
/*
* Set the internal variable to an empty object to signify that we
* don't hold an iterator.
*/
TclDecrRefCount(statePtr);
TclNewObj(emptyPtr);
(*LOCAL(opnd)).value.objPtr = emptyPtr;
Tcl_IncrRefCount(emptyPtr);
}
NEXT_INST_F(5, 0, 0);
}
{
int opnd, opnd2, i, length, allocdict;
Tcl_Obj **keyPtrPtr, *dictPtr, *valuePtr;
DictUpdateInfo *duiPtr;
Var *varPtr;
case INST_DICT_UPDATE_START:
opnd = TclGetUInt4AtPtr(pc+1);
opnd2 = TclGetUInt4AtPtr(pc+5);
varPtr = LOCAL(opnd);
duiPtr = codePtr->auxDataArrayPtr[opnd2].clientData;
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
TRACE(("%u => ", opnd));
if (TclIsVarDirectReadable(varPtr)) {
dictPtr = varPtr->value.objPtr;
|
| ︙ | ︙ | |||
7572 7573 7574 7575 7576 7577 7578 |
&keyPtrPtr) != TCL_OK) {
goto dictUpdateStartFailed;
}
if (length != duiPtr->length) {
Tcl_Panic("dictUpdateStart argument length mismatch");
}
for (i=0 ; i<length ; i++) {
| < < | | | | | < < > > > | | < | < | | | | | | | | | | | > | | 7546 7547 7548 7549 7550 7551 7552 7553 7554 7555 7556 7557 7558 7559 7560 7561 7562 7563 7564 7565 7566 7567 7568 7569 7570 7571 7572 7573 7574 7575 7576 7577 7578 7579 7580 7581 7582 7583 7584 7585 7586 7587 7588 7589 7590 7591 7592 7593 7594 7595 7596 7597 7598 7599 7600 7601 7602 7603 7604 7605 7606 7607 7608 7609 7610 7611 7612 7613 7614 7615 7616 7617 7618 7619 7620 7621 7622 7623 7624 7625 7626 7627 7628 7629 7630 7631 7632 7633 7634 7635 7636 7637 7638 7639 7640 7641 7642 7643 7644 7645 7646 7647 7648 7649 7650 7651 7652 7653 7654 7655 7656 7657 7658 7659 7660 7661 7662 7663 7664 7665 7666 7667 7668 7669 7670 7671 7672 7673 7674 7675 7676 7677 7678 7679 7680 7681 7682 7683 7684 |
&keyPtrPtr) != TCL_OK) {
goto dictUpdateStartFailed;
}
if (length != duiPtr->length) {
Tcl_Panic("dictUpdateStart argument length mismatch");
}
for (i=0 ; i<length ; i++) {
if (Tcl_DictObjGet(interp, dictPtr, keyPtrPtr[i],
&valuePtr) != TCL_OK) {
goto dictUpdateStartFailed;
}
varPtr = LOCAL(duiPtr->varIndices[i]);
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
DECACHE_STACK_INFO();
if (valuePtr == NULL) {
TclObjUnsetVar2(interp,
localName(iPtr->varFramePtr, duiPtr->varIndices[i]),
NULL, 0);
} else if (TclPtrSetVar(interp, varPtr, NULL, NULL, NULL,
valuePtr, TCL_LEAVE_ERR_MSG,
duiPtr->varIndices[i]) == NULL) {
CACHE_STACK_INFO();
goto dictUpdateStartFailed;
}
CACHE_STACK_INFO();
}
NEXT_INST_F(9, 0, 0);
dictUpdateStartFailed:
TRESULT = TCL_ERROR;
goto checkForCatch;
case INST_DICT_UPDATE_END:
opnd = TclGetUInt4AtPtr(pc+1);
opnd2 = TclGetUInt4AtPtr(pc+5);
varPtr = LOCAL(opnd);
duiPtr = codePtr->auxDataArrayPtr[opnd2].clientData;
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
TRACE(("%u => ", opnd));
if (TclIsVarDirectReadable(varPtr)) {
dictPtr = varPtr->value.objPtr;
} else {
DECACHE_STACK_INFO();
dictPtr = TclPtrGetVar(interp, varPtr, NULL, NULL, NULL, 0, opnd);
CACHE_STACK_INFO();
}
if (dictPtr == NULL) {
NEXT_INST_F(9, 1, 0);
}
if (Tcl_DictObjSize(interp, dictPtr, &length) != TCL_OK
|| TclListObjGetElements(interp, OBJ_AT_TOS, &length,
&keyPtrPtr) != TCL_OK) {
TRESULT = TCL_ERROR;
goto checkForCatch;
}
allocdict = Tcl_IsShared(dictPtr);
if (allocdict) {
dictPtr = Tcl_DuplicateObj(dictPtr);
}
for (i=0 ; i<length ; i++) {
Var *var2Ptr = LOCAL(duiPtr->varIndices[i]);
while (TclIsVarLink(var2Ptr)) {
var2Ptr = var2Ptr->value.linkPtr;
}
if (TclIsVarDirectReadable(var2Ptr)) {
valuePtr = var2Ptr->value.objPtr;
} else {
DECACHE_STACK_INFO();
valuePtr = TclPtrGetVar(interp, var2Ptr, NULL, NULL, NULL, 0,
duiPtr->varIndices[i]);
CACHE_STACK_INFO();
}
if (valuePtr == NULL) {
Tcl_DictObjRemove(interp, dictPtr, keyPtrPtr[i]);
} else if (dictPtr == valuePtr) {
Tcl_DictObjPut(interp, dictPtr, keyPtrPtr[i],
Tcl_DuplicateObj(valuePtr));
} else {
Tcl_DictObjPut(interp, dictPtr, keyPtrPtr[i], valuePtr);
}
}
if (TclIsVarDirectWritable(varPtr)) {
Tcl_IncrRefCount(dictPtr);
TclDecrRefCount(varPtr->value.objPtr);
varPtr->value.objPtr = dictPtr;
} else {
DECACHE_STACK_INFO();
objResultPtr = TclPtrSetVar(interp, varPtr, NULL, NULL, NULL,
dictPtr, TCL_LEAVE_ERR_MSG, opnd);
CACHE_STACK_INFO();
if (objResultPtr == NULL) {
if (allocdict) {
TclDecrRefCount(dictPtr);
}
TRESULT = TCL_ERROR;
goto checkForCatch;
}
}
NEXT_INST_F(9, 1, 0);
}
default:
Tcl_Panic("TclExecuteByteCode: unrecognized opCode %u", *pc);
} /* end of switch on opCode */
/*
* Division by zero in an expression. Control only reaches this point by
* "goto divideByZero".
*/
divideByZero:
Tcl_SetResult(interp, "divide by zero", TCL_STATIC);
Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero", NULL);
TRESULT = TCL_ERROR;
goto checkForCatch;
/*
* Exponentiation of zero by negative number in an expression. Control
* only reaches this point by "goto exponOfZero".
*/
exponOfZero:
Tcl_SetResult(interp, "exponentiation of zero by negative power",
TCL_STATIC);
Tcl_SetErrorCode(interp, "ARITH", "DOMAIN",
"exponentiation of zero by negative power", NULL);
TRESULT = TCL_ERROR;
goto checkForCatch;
/*
* Block for variables needed to process exception returns.
*/
{
|
| ︙ | ︙ | |||
7747 7748 7749 7750 7751 7752 7753 |
TRACE(("\"%.30s\" => ", O2S(OBJ_AT_TOS)));
break;
default:
TRACE(("=> "));
}
#endif
| | | | | | | | | | | > | > | | | < | | | | | > | | | | | 7719 7720 7721 7722 7723 7724 7725 7726 7727 7728 7729 7730 7731 7732 7733 7734 7735 7736 7737 7738 7739 7740 7741 7742 7743 7744 7745 7746 7747 7748 7749 7750 7751 7752 7753 7754 7755 7756 7757 7758 7759 7760 7761 7762 7763 7764 7765 7766 7767 7768 7769 7770 7771 7772 7773 7774 7775 7776 7777 7778 7779 7780 7781 7782 7783 7784 7785 7786 7787 7788 7789 7790 7791 7792 7793 7794 7795 7796 7797 7798 7799 7800 7801 7802 7803 7804 7805 7806 7807 7808 7809 7810 7811 7812 7813 7814 7815 7816 7817 7818 7819 7820 7821 7822 7823 7824 7825 7826 7827 7828 7829 7830 7831 7832 7833 7834 7835 7836 7837 7838 7839 7840 7841 7842 7843 7844 7845 7846 7847 7848 7849 7850 7851 7852 7853 7854 7855 7856 7857 7858 7859 7860 7861 7862 7863 7864 7865 7866 7867 7868 7869 7870 7871 7872 7873 7874 |
TRACE(("\"%.30s\" => ", O2S(OBJ_AT_TOS)));
break;
default:
TRACE(("=> "));
}
#endif
if ((TRESULT == TCL_CONTINUE) || (TRESULT == TCL_BREAK)) {
rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0, codePtr);
if (rangePtr == NULL) {
TRACE_APPEND(("no encl. loop or catch, returning %s\n",
StringForResultCode(TRESULT)));
goto abnormalReturn;
}
if (rangePtr->type == CATCH_EXCEPTION_RANGE) {
TRACE_APPEND(("%s ...\n", StringForResultCode(TRESULT)));
goto processCatch;
}
while (cleanup--) {
valuePtr = POP_OBJECT();
TclDecrRefCount(valuePtr);
}
if (TRESULT == TCL_BREAK) {
TRESULT = TCL_OK;
pc = (codePtr->codeStart + rangePtr->breakOffset);
TRACE_APPEND(("%s, range at %d, new pc %d\n",
StringForResultCode(TRESULT),
rangePtr->codeOffset, rangePtr->breakOffset));
NEXT_INST_F(0, 0, 0);
} else {
if (rangePtr->continueOffset == -1) {
TRACE_APPEND((
"%s, loop w/o continue, checking for catch\n",
StringForResultCode(TRESULT)));
goto checkForCatch;
}
TRESULT = TCL_OK;
pc = (codePtr->codeStart + rangePtr->continueOffset);
TRACE_APPEND(("%s, range at %d, new pc %d\n",
StringForResultCode(TRESULT),
rangePtr->codeOffset, rangePtr->continueOffset));
NEXT_INST_F(0, 0, 0);
}
#if TCL_COMPILE_DEBUG
} else if (traceInstructions) {
if ((TRESULT != TCL_ERROR) && (TRESULT != TCL_RETURN)) {
Tcl_Obj *objPtr = Tcl_GetObjResult(interp);
TRACE_APPEND(("OTHER RETURN CODE %d, result= \"%s\"\n ",
TRESULT, O2S(objPtr)));
} else {
Tcl_Obj *objPtr = Tcl_GetObjResult(interp);
TRACE_APPEND(("%s, result= \"%s\"\n",
StringForResultCode(TRESULT), O2S(objPtr)));
}
#endif
}
/*
* Execution has generated an "exception" such as TCL_ERROR. If the
* exception is an error, record information about what was being
* executed when the error occurred. Find the closest enclosing catch
* range, if any. If no enclosing catch range is found, stop execution
* and return the "exception" code.
*/
checkForCatch:
if (iPtr->execEnvPtr->rewind) {
goto abnormalReturn;
}
if ((TRESULT == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
bytes = GetSrcInfoForPc(pc, codePtr, &length);
if (bytes != NULL) {
DECACHE_STACK_INFO();
Tcl_LogCommandInfo(interp, codePtr->source, bytes, length);
CACHE_STACK_INFO();
}
}
iPtr->flags &= ~ERR_ALREADY_LOGGED;
/*
* Clear all expansions that may have started after the last
* INST_BEGIN_CATCH.
*/
while (auxObjList) {
if ((catchTop != initCatchTop) && (*catchTop >
(ptrdiff_t) auxObjList->internalRep.twoPtrValue.ptr1)) {
break;
}
POP_TAUX_OBJ();
}
/*
* We must not catch if the script in progress has been canceled with
* the TCL_CANCEL_UNWIND flag. Instead, it blows outwards until we
* either hit another interpreter (presumably where the script in
* progress has not been canceled) or we get to the top-level. We do
* NOT modify the interpreter result here because we know it will
* already be set prior to vectoring down to this point in the code.
*/
if (Tcl_Canceled(interp, 0) == TCL_ERROR) {
#ifdef TCL_COMPILE_DEBUG
if (traceInstructions) {
fprintf(stdout, " ... cancel with unwind, returning %s\n",
StringForResultCode(TRESULT));
}
#endif
goto abnormalReturn;
}
/*
* We must not catch an exceeded limit. Instead, it blows outwards
* until we either hit another interpreter (presumably where the limit
* is not exceeded) or we get to the top-level.
*/
if (TclLimitExceeded(iPtr->limit)) {
#ifdef TCL_COMPILE_DEBUG
if (traceInstructions) {
fprintf(stdout, " ... limit exceeded, returning %s\n",
StringForResultCode(TRESULT));
}
#endif
goto abnormalReturn;
}
if (catchTop == initCatchTop) {
#ifdef TCL_COMPILE_DEBUG
if (traceInstructions) {
fprintf(stdout, " ... no enclosing catch, returning %s\n",
StringForResultCode(TRESULT));
}
#endif
goto abnormalReturn;
}
rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 1, codePtr);
if (rangePtr == NULL) {
/*
* This is only possible when compiling a [catch] that sends its
* script to INST_EVAL. Cannot correct the compiler without
* breaking compat with previous .tbc compiled scripts.
*/
#ifdef TCL_COMPILE_DEBUG
if (traceInstructions) {
fprintf(stdout, " ... no enclosing catch, returning %s\n",
StringForResultCode(TRESULT));
}
#endif
goto abnormalReturn;
}
/*
* A catch exception range (rangePtr) was found to handle an
|
| ︙ | ︙ | |||
7933 7934 7935 7936 7937 7938 7939 |
abnormalReturn:
TCL_DTRACE_INST_LAST();
/*
* Winding down: insure that all pending cleanups are done before
* dropping out of this bytecode.
*/
| | | | | | | | | | | < | < > | | | | | | | | | | | | | | | | | | | > > > > > | 7907 7908 7909 7910 7911 7912 7913 7914 7915 7916 7917 7918 7919 7920 7921 7922 7923 7924 7925 7926 7927 7928 7929 7930 7931 7932 7933 7934 7935 7936 7937 7938 7939 7940 7941 7942 7943 7944 7945 7946 7947 7948 7949 7950 7951 7952 7953 7954 7955 7956 7957 7958 7959 7960 7961 7962 7963 7964 7965 7966 7967 7968 7969 7970 7971 7972 7973 7974 7975 7976 7977 7978 7979 7980 7981 7982 7983 7984 7985 7986 7987 7988 7989 7990 7991 7992 7993 7994 7995 7996 7997 7998 7999 8000 8001 8002 8003 8004 8005 8006 8007 8008 8009 8010 8011 8012 8013 8014 8015 8016 8017 8018 8019 8020 8021 8022 8023 8024 8025 |
abnormalReturn:
TCL_DTRACE_INST_LAST();
/*
* Winding down: insure that all pending cleanups are done before
* dropping out of this bytecode.
*/
if (TOP_CB(interp) != BP->rootPtr) {
TRESULT = TclNRRunCallbacks(interp, TRESULT, BP->rootPtr, 1);
if (TOP_CB(interp) != BP->rootPtr) {
Tcl_Panic("Abnormal return with busy callback stack");
}
}
/*
* Clear all expansions and same-level NR calls.
*
* Note that expansion markers have a NULL type; avoid removing other
* markers.
*/
while (auxObjList) {
POP_TAUX_OBJ();
}
while (tosPtr > initTosPtr) {
Tcl_Obj *objPtr = POP_OBJECT();
Tcl_DecrRefCount(objPtr);
}
if (tosPtr < initTosPtr) {
fprintf(stderr,
"\nTclExecuteByteCode: abnormal return at pc %u: "
"stack top %d < entry stack top %d\n",
(unsigned)(pc - codePtr->codeStart),
(unsigned) CURR_DEPTH, (unsigned) 0);
Tcl_Panic("TclExecuteByteCode execution failure: end stack top < start stack top");
}
CLANG_ASSERT(bcFramePtr);
}
OBP = BP->prevBottomPtr;
iPtr->cmdFramePtr = bcFramePtr->nextPtr;
TclStackFree(interp, BP); /* free my stack */
if (--codePtr->refCount <= 0) {
TclCleanupByteCode(codePtr);
}
returnToCaller:
if (OBP) {
/*
* Restore the state to what it was previous to this bytecode, deal
* with tailcalls.
*/
BP = OBP; /* back to old bc */
rerunCallbacks:
TRESULT = TclNRRunCallbacks(interp, TRESULT, BP->rootPtr, 1);
NR_DATA_DIG();
if (TOP_CB(interp) == BP->rootPtr) {
/*
* The bytecode is returning, all callbacks were run. Remove the
* caller's arguments and keep processing the caller.
*/
TAUX.esPtr = iPtr->execEnvPtr->execStackPtr;
TAUX.compiledLocals = iPtr->varFramePtr->compiledLocals;
goto nonRecursiveCallReturn;
} else {
TEOV_callback *callbackPtr = TOP_CB(iPtr);
int type = PTR2INT(callbackPtr->data[0]);
NRE_ASSERT(TOP_CB(interp)->procPtr == NRCallTEBC);
NRE_ASSERT(TRESULT == TCL_OK);
switch (type) {
case TCL_NR_BC_TYPE:
/*
* One of the callbacks requested a new execution: a tailcall!
* Start the new bytecode.
*/
goto nonRecursiveCallSetup;
case TCL_NR_TAILCALL_TYPE:
TOP_CB(iPtr) = callbackPtr->nextPtr;
TCLNR_FREE(interp, callbackPtr);
Tcl_SetResult(interp,
"atProcExit/tailcall cannot be invoked recursively",
TCL_STATIC);
TRESULT = TCL_ERROR;
goto rerunCallbacks;
default:
Tcl_Panic("TEBC: TRCB sent us a callback we cannot handle!");
}
}
}
iPtr->execEnvPtr->bottomPtr = NULL;
return TRESULT;
}
#undef iPtr
#undef bcFramePtr
#undef initCatchTop
#undef initTosPtr
#undef auxObjList
#undef catchTop
#ifdef TCL_COMPILE_DEBUG
/*
*----------------------------------------------------------------------
*
* PrintByteCodeInfo --
*
|
| ︙ | ︙ |
Changes to generic/tclInt.h.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 | * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net> * Copyright (c) 2006-2008 by Joe Mistachkin. All rights reserved. * Copyright (c) 2008 by Miguel Sofer. All rights reserved. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 | * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net> * Copyright (c) 2006-2008 by Joe Mistachkin. All rights reserved. * Copyright (c) 2008 by Miguel Sofer. 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: tclInt.h,v 1.127.2.131 2009/12/08 18:39:19 dgp Exp $ */ #ifndef _TCLINT #define _TCLINT /* * Some numerics configuration options. |
| ︙ | ︙ | |||
1396 1397 1398 1399 1400 1401 1402 |
struct ExecEnv *callerEEPtr;/* The execution environment for the caller of
* the coroutine, which might be the
* interpreter global environment or another
* coroutine. */
CorContext caller;
CorContext running;
CorContext base;
| | | 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 |
struct ExecEnv *callerEEPtr;/* The execution environment for the caller of
* the coroutine, which might be the
* interpreter global environment or another
* coroutine. */
CorContext caller;
CorContext running;
CorContext base;
void *stackLevel;
int auxNumLevels; /* While the coroutine is running the
* numLevels of the create/resume command is
* stored here; for suspended coroutines it
* holds the nesting numLevels at yield. */
} CoroutineData;
typedef struct ExecEnv {
|
| ︙ | ︙ | |||
2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 | MODULE_SCOPE Tcl_ObjCmdProc TclNRTryObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRWhileObjCmd; MODULE_SCOPE Tcl_NRPostProc TclNRForIterCallback; MODULE_SCOPE Tcl_ObjCmdProc TclNRTailcallObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRCoroutineObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd; MODULE_SCOPE void TclClearTailcall(Tcl_Interp *interp, struct TEOV_callback *tailcallPtr); /* * This structure holds the data for the various iteration callbacks used to * NRE the 'for' and 'while' commands. We need a separate structure because we * have more than the 4 client data entries we can provide directly thorugh * the callback API. It is the 'word' information which puts us over the | > > > | 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 | MODULE_SCOPE Tcl_ObjCmdProc TclNRTryObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRWhileObjCmd; MODULE_SCOPE Tcl_NRPostProc TclNRForIterCallback; MODULE_SCOPE Tcl_ObjCmdProc TclNRTailcallObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRCoroutineObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldToObjCmd; MODULE_SCOPE void TclClearTailcall(Tcl_Interp *interp, struct TEOV_callback *tailcallPtr); MODULE_SCOPE void TclSpliceTailcall(Tcl_Interp *interp, struct TEOV_callback *tailcallPtr); /* * This structure holds the data for the various iteration callbacks used to * NRE the 'for' and 'while' commands. We need a separate structure because we * have more than the 4 client data entries we can provide directly thorugh * the callback API. It is the 'word' information which puts us over the |
| ︙ | ︙ |
Changes to generic/tclInterp.c.
1 2 3 4 5 6 7 8 9 10 11 12 | /* * tclInterp.c -- * * This file implements the "interp" command which allows creation and * manipulation of Tcl interpreters from within Tcl scripts. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * Copyright (c) 2004 Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | /* * tclInterp.c -- * * This file implements the "interp" command which allows creation and * manipulation of Tcl interpreters from within Tcl scripts. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * Copyright (c) 2004 Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclInterp.c,v 1.22.2.41 2009/12/08 18:39:19 dgp Exp $ */ #include "tclInt.h" /* * A pointer to a string that holds an initialization script that if non-NULL * is evaluated in Tcl_Init() prior to the built-in initialization script |
| ︙ | ︙ | |||
1801 1802 1803 1804 1805 1806 1807 |
/*
* We are sending a 0-refCount obj, do not need a callback: it will be
* cleaned up automatically. But we may need to clear the rootEnsemble
* stuff ...
*/
if (isRootEnsemble) {
| | | 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 |
/*
* We are sending a 0-refCount obj, do not need a callback: it will be
* cleaned up automatically. But we may need to clear the rootEnsemble
* stuff ...
*/
if (isRootEnsemble) {
TclNRDeferCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL);
}
iPtr->evalFlags |= TCL_EVAL_REDIRECT;
return Tcl_NREvalObj(interp, listPtr, flags);
}
static int
AliasObjCmd(
|
| ︙ | ︙ |
Changes to generic/tclNamesp.c.
| ︙ | ︙ | |||
19 20 21 22 23 24 25 | * Michael J. McLennan * Bell Labs Innovations for Lucent Technologies * mmclennan@lucent.com * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 | * Michael J. McLennan * Bell Labs Innovations for Lucent Technologies * mmclennan@lucent.com * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclNamesp.c,v 1.31.4.69 2009/12/08 18:39:19 dgp Exp $ */ #include "tclInt.h" #include "tclCompile.h" /* just for NRCommand */ /* * Thread-local storage used to avoid having a global lock on data that is not |
| ︙ | ︙ | |||
506 507 508 509 510 511 512 |
if ((nsPtr->flags & NS_DYING)
&& (nsPtr->activationCount - (nsPtr == iPtr->globalNsPtr) == 0)) {
Tcl_DeleteNamespace((Tcl_Namespace *) nsPtr);
}
framePtr->nsPtr = NULL;
if (framePtr->tailcallPtr) {
| < < < < < < < < < < < < < < < < < | < < < | 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 |
if ((nsPtr->flags & NS_DYING)
&& (nsPtr->activationCount - (nsPtr == iPtr->globalNsPtr) == 0)) {
Tcl_DeleteNamespace((Tcl_Namespace *) nsPtr);
}
framePtr->nsPtr = NULL;
if (framePtr->tailcallPtr) {
TclSpliceTailcall(interp, framePtr->tailcallPtr);
}
}
/*
*----------------------------------------------------------------------
*
* TclPushStackFrame --
|
| ︙ | ︙ |
Changes to generic/tclOO.h.
1 2 3 4 5 6 7 8 9 10 11 | /* * tclOO.h -- * * This file contains the public API definitions and some of the function * declarations for the object-system (NB: not Tcl_Obj, but ::oo). * * Copyright (c) 2006-2008 by Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | > | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 | /* * tclOO.h -- * * This file contains the public API definitions and some of the function * declarations for the object-system (NB: not Tcl_Obj, but ::oo). * * Copyright (c) 2006-2008 by Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclOO.h,v 1.4.2.7 2009/12/08 18:39:19 dgp Exp $ */ #ifndef TCLOO_H_INCLUDED #define TCLOO_H_INCLUDED #include "tcl.h" #if defined(BUILD_tcloo) # define TCLOOAPI DLLEXPORT # undef USE_TCLOO_STUBS #else # define TCLOOAPI DLLIMPORT #endif /* * Be careful when it comes to versioning; need to make sure that the * standalone TclOO version matches. Also make sure that this matches the * version in the files: * * tests/oo.test * unix/tclooConfig.sh * win/tclooConfig.sh */ #define TCLOO_VERSION "0.6.2" #define TCLOO_PATCHLEVEL TCLOO_VERSION /* * These are opaque types. */ typedef struct Tcl_Class_ *Tcl_Class; |
| ︙ | ︙ |
Changes to generic/tclOOBasic.c.
1 2 3 4 5 6 7 8 9 10 11 | /* * tclOOBasic.c -- * * This file contains implementations of the "simple" commands and * methods from the object-system core. * * Copyright (c) 2005-2008 by Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | /* * tclOOBasic.c -- * * This file contains implementations of the "simple" commands and * methods from the object-system core. * * Copyright (c) 2005-2008 by Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclOOBasic.c,v 1.1.2.14 2009/12/08 18:39:19 dgp Exp $ */ #ifdef HAVE_CONFIG_H #include "config.h" #endif #include "tclInt.h" #include "tclOOInt.h" |
| ︙ | ︙ | |||
470 471 472 473 474 475 476 |
if (objc-Tcl_ObjectContextSkippedArgs(context) < 0) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"?varName ...?");
return TCL_ERROR;
}
/*
| | | > | < | 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 |
if (objc-Tcl_ObjectContextSkippedArgs(context) < 0) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"?varName ...?");
return TCL_ERROR;
}
/*
* A sanity check. Shouldn't ever happen. (This is all that remains of a
* more complex check inherited from [global] after we have applied the
* fix for [Bug 2903811]; note that the fix involved *removing* code.)
*/
if (iPtr->varFramePtr == NULL) {
return TCL_OK;
}
for (i=Tcl_ObjectContextSkippedArgs(context) ; i<objc ; i++) {
Var *varPtr, *aryPtr;
const char *varName = TclGetString(objv[i]);
|
| ︙ | ︙ | |||
501 502 503 504 505 506 507 | /* * Switch to the object's namespace for the duration of this call. * Like this, the variable is looked up in the namespace of the * object, and not in the namespace of the caller. Otherwise this * would only work if the caller was a method of the object itself, * which might not be true if the method was exported. This is a bit * of a hack, but the simplest way to do this (pushing a stack frame | | < < | 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 | /* * Switch to the object's namespace for the duration of this call. * Like this, the variable is looked up in the namespace of the * object, and not in the namespace of the caller. Otherwise this * would only work if the caller was a method of the object itself, * which might not be true if the method was exported. This is a bit * of a hack, but the simplest way to do this (pushing a stack frame * would be horribly expensive by comparison). */ savedNsPtr = iPtr->varFramePtr->nsPtr; iPtr->varFramePtr->nsPtr = (Namespace *) Tcl_GetObjectNamespace(object); varPtr = TclObjLookupVar(interp, objv[i], NULL, TCL_NAMESPACE_ONLY, "define", 1, 0, &aryPtr); |
| ︙ | ︙ |
Changes to generic/tclStrToD.c.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 | * 'double' and 'mp_int' types. * * Copyright (c) 2005 by Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | * 'double' and 'mp_int' types. * * Copyright (c) 2005 by Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclStrToD.c,v 1.4.2.24 2009/12/08 18:39:19 dgp Exp $ * *---------------------------------------------------------------------- */ #include <tclInt.h> #include <stdio.h> #include <stdlib.h> |
| ︙ | ︙ | |||
67 68 69 70 71 72 73 | */ #if defined(__sun) && defined(__i386) && !defined(__GNUC__) #include <sunmath.h> #endif /* * MIPS floating-point units need special settings in control registers | | > | | 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 | */ #if defined(__sun) && defined(__i386) && !defined(__GNUC__) #include <sunmath.h> #endif /* * MIPS floating-point units need special settings in control registers * to use gradual underflow as we expect. This fix is for the MIPSpro * compiler. */ #if defined(__sgi) && defined(_COMPILER_VERSION) #include <sys/fpu.h> #endif /* * HP's PA_RISC architecture uses 7ff4000000000000 to represent a quiet NaN. * Everyone else uses 7ff8000000000000. (Why, HP, why?) */ |
| ︙ | ︙ | |||
2170 2171 2172 2173 2174 2175 2176 |
#ifdef IEEE_FLOATING_POINT
union {
double dv;
Tcl_WideUInt iv;
} bitwhack;
#endif
| | | 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 |
#ifdef IEEE_FLOATING_POINT
union {
double dv;
Tcl_WideUInt iv;
} bitwhack;
#endif
#if defined(__sgi) && defined(_COMPILER_VERSION)
union fpc_csr mipsCR;
mipsCR.fc_word = get_fpc_csr();
mipsCR.fc_struct.flush = 0;
set_fpc_csr(mipsCR.fc_word);
#endif
|
| ︙ | ︙ |
Changes to generic/tclThreadAlloc.c.
1 2 3 4 5 6 7 8 9 10 11 12 13 | /* * tclThreadAlloc.c -- * * This is a very fast storage allocator for used with threads (designed * avoid lock contention). The basic strategy is to allocate memory in * fixed size blocks from block caches. * * The Initial Developer of the Original Code is America Online, Inc. * Portions created by AOL are Copyright (C) 1999 America Online, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | /* * tclThreadAlloc.c -- * * This is a very fast storage allocator for used with threads (designed * avoid lock contention). The basic strategy is to allocate memory in * fixed size blocks from block caches. * * The Initial Developer of the Original Code is America Online, Inc. * Portions created by AOL are Copyright (C) 1999 America Online, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclThreadAlloc.c,v 1.6.2.19 2009/12/08 18:39:20 dgp Exp $ */ #include "tclInt.h" #if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) /* * If range checking is enabled, an additional byte will be allocated to store |
| ︙ | ︙ | |||
293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 |
unsigned int reqSize)
{
Cache *cachePtr;
Block *blockPtr;
register int bucket;
size_t size;
if (sizeof(int) >= sizeof(size_t)) {
/* An unsigned int overflow can also be a size_t overflow */
const size_t zero = 0;
const size_t max = ~zero;
if (((size_t) reqSize) > max - sizeof(Block) - RCHECK) {
/* Requested allocation exceeds memory */
return NULL;
}
}
cachePtr = TclpGetAllocCache();
if (cachePtr == NULL) {
cachePtr = GetCache();
}
/*
| > > | 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 |
unsigned int reqSize)
{
Cache *cachePtr;
Block *blockPtr;
register int bucket;
size_t size;
#ifndef __LP64__
if (sizeof(int) >= sizeof(size_t)) {
/* An unsigned int overflow can also be a size_t overflow */
const size_t zero = 0;
const size_t max = ~zero;
if (((size_t) reqSize) > max - sizeof(Block) - RCHECK) {
/* Requested allocation exceeds memory */
return NULL;
}
}
#endif
cachePtr = TclpGetAllocCache();
if (cachePtr == NULL) {
cachePtr = GetCache();
}
/*
|
| ︙ | ︙ | |||
436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 |
size_t size, min;
int bucket;
if (ptr == NULL) {
return TclpAlloc(reqSize);
}
if (sizeof(int) >= sizeof(size_t)) {
/* An unsigned int overflow can also be a size_t overflow */
const size_t zero = 0;
const size_t max = ~zero;
if (((size_t) reqSize) > max - sizeof(Block) - RCHECK) {
/* Requested allocation exceeds memory */
return NULL;
}
}
cachePtr = TclpGetAllocCache();
if (cachePtr == NULL) {
cachePtr = GetCache();
}
/*
| > > | 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 |
size_t size, min;
int bucket;
if (ptr == NULL) {
return TclpAlloc(reqSize);
}
#ifndef __LP64__
if (sizeof(int) >= sizeof(size_t)) {
/* An unsigned int overflow can also be a size_t overflow */
const size_t zero = 0;
const size_t max = ~zero;
if (((size_t) reqSize) > max - sizeof(Block) - RCHECK) {
/* Requested allocation exceeds memory */
return NULL;
}
}
#endif
cachePtr = TclpGetAllocCache();
if (cachePtr == NULL) {
cachePtr = GetCache();
}
/*
|
| ︙ | ︙ |
Changes to library/safe.tcl.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | # See the safe.n man page for details. # # Copyright (c) 1996-1997 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | # See the safe.n man page for details. # # Copyright (c) 1996-1997 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: safe.tcl,v 1.10.2.13 2009/12/08 18:39:20 dgp Exp $ # # The implementation is based on namespaces. These naming conventions are # followed: # Private procs starts with uppercase. # Public procs are exported and starts with lowercase # |
| ︙ | ︙ | |||
647 648 649 650 651 652 653 |
if {![file readable $file]} {
# don't tell the file path
return -code error "not readable"
}
}
# AliasGlob is the target of the "glob" alias in safe interpreters.
| < | | < < | < | > < < < < < < | > > > > > > > > | 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 |
if {![file readable $file]} {
# don't tell the file path
return -code error "not readable"
}
}
# AliasGlob is the target of the "glob" alias in safe interpreters.
proc ::safe::AliasGlob {slave args} {
Log $slave "GLOB ! $args" NOTICE
set cmd {}
set at 0
set dir {}
set virtualdir {}
while {$at < [llength $args]} {
switch -glob -- [set opt [lindex $args $at]] {
-nocomplain -
-join {
lappend cmd $opt
incr at
}
-directory {
set virtualdir [lindex $args [incr at]]
# Get the real path from the virtual one and check that the
# path is in the access path of that slave.
try {
set dir [TranslatePath $slave $virtualdir]
DirInAccessPath $slave $dir
} on error msg {
Log $slave $msg
return -code error "permission denied"
}
lappend cmd -directory $dir
incr at
}
pkgIndex.tcl {
# Oops, this is globbing a subdirectory in regular package
# search. That is not wanted. Abort, handler does catch
# already (because glob was not defined before). See
# package.tcl, lines 484ff in tclPkgUnknown.
return -code error "unknown command glob"
}
-* {
Log $slave "Safe base rejecting glob option '$opt'"
return -code error "Safe base rejecting glob option '$opt'"
}
default {
if {[regexp {(.*)[\\/]} $opt -> thedir]} {
try {
DirInAccessPath $slave [TranslatePath $slave $thedir]
} on error msg {
Log $slave $msg
return -code error "permission denied"
}
}
lappend cmd $opt
incr at
}
}
}
Log $slave "GLOB = $cmd" NOTICE
|
| ︙ | ︙ | |||
924 925 926 927 928 929 930 |
set pat "^([join $args |])\$"
::interp alias $slave $alias {}\
[namespace current]::Subset $slave $target $pat
}
# AliasEncoding is the target of the "encoding" alias in safe interpreters.
| | < | | < < < | | | > | > | < | 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 |
set pat "^([join $args |])\$"
::interp alias $slave $alias {}\
[namespace current]::Subset $slave $target $pat
}
# AliasEncoding is the target of the "encoding" alias in safe interpreters.
proc ::safe::AliasEncoding {slave option args} {
# Careful; do not want empty option to get through to the [string equal]
if {[regexp {^(name.*|convert.*|)$} $option]} {
return [::interp invokehidden $slave encoding $option {*}$args]
}
if {[string equal -length [string length $option] $option "system"]} {
if {[llength $args] == 0} {
# passed all the tests , lets source it:
try {
return [::interp invokehidden $slave encoding system]
} on error msg {
Log $slave $msg
return -code error "script error"
}
}
set msg "wrong # args: should be \"encoding system\""
set code {TCL WRONGARGS}
} else {
set msg "bad option \"$option\": must be convertfrom, convertto, names, or system"
set code [list TCL LOOKUP INDEX option $option]
}
Log $slave $msg
return -code error -errorcode $code $msg
}
proc ::safe::Setup {} {
####
#
# Setup the arguments parsing
#
####
# Share the descriptions
|
| ︙ | ︙ |
Changes to tests/coroutine.test.
1 2 3 4 5 6 7 8 9 10 11 | # Commands covered: coroutine, yield, [info coroutine] # # This file contains a collection of tests for experimental commands that are # found in ::tcl::unsupported. The tests will migrate to normal test files # if/when the commands find their way into the core. # # Copyright (c) 2008 by Miguel Sofer. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
# Commands covered: coroutine, yield, [info coroutine]
#
# This file contains a collection of tests for experimental commands that are
# found in ::tcl::unsupported. The tests will migrate to normal test files
# if/when the commands find their way into the core.
#
# Copyright (c) 2008 by Miguel Sofer.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: coroutine.test,v 1.1.2.7 2009/12/08 18:39:20 dgp Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint testnrelevels [llength [info commands testnrelevels]]
set lambda [list {{start 0} {stop 10}} {
# init
set i $start
set imax $stop
yield
while {$i < $imax} {
yield [expr {$i*$stop}]
|
| ︙ | ︙ | |||
358 359 360 361 362 363 364 365 366 367 368 369 370 371 |
proc b {} {rename [info coroutine] {}; a}
} -body {
coroutine foo b
} -cleanup {
rename a {}
rename b {}
} -result {}
test coroutine-4.1 {bug #2093188} -setup {
proc foo {} {
set v 1
trace add variable v {write unset} bar
yield
set v 2
| > > > > > > > > > > > > > > > > > > | 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 |
proc b {} {rename [info coroutine] {}; a}
} -body {
coroutine foo b
} -cleanup {
rename a {}
rename b {}
} -result {}
test coroutine-3.6 {info frame, bug #2910094} -setup {
proc stack {} {
set res [list "LEVEL:[set lev [info frame]]"]
for {set i 1} {$i < $lev} {incr i} {
lappend res [info frame $i]
}
set res
# the precise command depends on line numbers and such, is likely not
# to be stable: just check that the test completes!
return
}
proc a {} stack
} -body {
coroutine aa a
} -cleanup {
rename stack {}
rename a {}
} -result {}
test coroutine-4.1 {bug #2093188} -setup {
proc foo {} {
set v 1
trace add variable v {write unset} bar
yield
set v 2
|
| ︙ | ︙ | |||
501 502 503 504 505 506 507 |
rename getNumLevel {}
rename relativeLevel {}
unset res
} -result {0 0 0 0}
unset lambda
| < < < < < | 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 |
rename getNumLevel {}
rename relativeLevel {}
unset res
} -result {0 0 0 0}
unset lambda
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to tests/error.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Commands covered: error, catch, throw, try # # This file contains a collection of tests for one or more of the Tcl built-in # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 |
# Commands covered: error, catch, throw, try
#
# This file contains a collection of tests for one or more of the Tcl built-in
# commands. Sourcing this file into Tcl runs the tests and generates output
# for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: error.test,v 1.10.2.10 2009/12/08 18:39:20 dgp Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
testConstraint memory [llength [info commands memory]]
namespace eval ::tcl::test::error {
if {[testConstraint memory]} {
proc getbytes {} {
set lines [split [memory info] \n]
return [lindex $lines 3 3]
}
proc leaktest {script {iterations 3}} {
set end [getbytes]
for {set i 0} {$i < $iterations} {incr i} {
uplevel 1 $script
set tmp $end
set end [getbytes]
}
return [expr {$end - $tmp}]
}
}
proc foo {} {
global errorInfo
set a [catch {format [error glorp2]} b]
error {Human-generated}
}
|
| ︙ | ︙ | |||
796 797 798 799 800 801 802 803 804 805 806 807 808 809 |
test error-20.1 {bad code name in on handler} -body {
try { list a b c } on foo {} {}
} -returnCodes error -match glob -result {bad code *}
test error-20.2 {bad code value in on handler} -body {
try { list a b c } on 34985723094872345 {} {}
} -returnCodes error -match glob -result {bad code *}
# negative case try tests - bad "trap" handler
# what is the effect if we attempt to trap an errorcode that is not a list?
# nested try
# catch inside try
# no tests for bad varslist?
# -errorcode but code!=1 doesn't trap
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 |
test error-20.1 {bad code name in on handler} -body {
try { list a b c } on foo {} {}
} -returnCodes error -match glob -result {bad code *}
test error-20.2 {bad code value in on handler} -body {
try { list a b c } on 34985723094872345 {} {}
} -returnCodes error -match glob -result {bad code *}
test error-21.1 {memory leaks in try: Bug 2910044} memory {
leaktest {
try {string repeat x 10} on ok {} {}
}
} 0
test error-21.2 {memory leaks in try: Bug 2910044} memory {
leaktest {
try {error [string repeat x 10]} on error {} {}
}
} 0
test error-21.3 {memory leaks in try: Bug 2910044} memory {
leaktest {
try {throw FOO [string repeat x 10]} trap FOO {} {}
}
} 0
test error-21.4 {memory leaks in try: Bug 2910044} memory {
leaktest {
try {string repeat x 10}
}
} 0
test error-21.5 {memory leaks in try: Bug 2910044} memory {
leaktest {
try {string repeat x 10} on ok {} {} finally {string repeat y 10}
}
} 0
test error-21.6 {memory leaks in try: Bug 2910044} memory {
leaktest {
try {
error [string repeat x 10]
} on error {} {} finally {
string repeat y 10
}
}
} 0
test error-21.7 {memory leaks in try: Bug 2910044} memory {
leaktest {
try {
throw FOO [string repeat x 10]
} trap FOO {} {} finally {
string repeat y 10
}
}
} 0
test error-21.8 {memory leaks in try: Bug 2910044} memory {
leaktest {
try {string repeat x 10} finally {string repeat y 10}
}
} 0
# negative case try tests - bad "trap" handler
# what is the effect if we attempt to trap an errorcode that is not a list?
# nested try
# catch inside try
# no tests for bad varslist?
# -errorcode but code!=1 doesn't trap
|
| ︙ | ︙ |
Changes to tests/oo.test.
1 2 3 4 5 6 7 8 9 | # This file contains a collection of tests for Tcl's built-in object system. # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # # Copyright (c) 2006-2008 Donal K. Fellows # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
# This file contains a collection of tests for Tcl's built-in object system.
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# Copyright (c) 2006-2008 Donal K. Fellows
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: oo.test,v 1.4.2.25 2009/12/08 18:39:20 dgp Exp $
package require -exact TclOO 0.6.2 ;# Must match value in generic/tclOO.h
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
testConstraint memory [llength [info commands memory]]
if {[testConstraint memory]} {
|
| ︙ | ︙ | |||
1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 |
foo destroy
} -body {
oo::objdefine foo method demo {} {
my variable
}
foo demo
} -result {}
test oo-21.1 {OO: inheritance ordering} -setup {
oo::class create A
} -body {
oo::define A method m {} {lappend ::result A}
oo::class create B {
superclass A
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 |
foo destroy
} -body {
oo::objdefine foo method demo {} {
my variable
}
foo demo
} -result {}
test oo-20.13 {OO: variable method use in non-methods [Bug 2903811]} -setup {
oo::object create fooObj
oo::objdefine fooObj export variable
} -cleanup {
fooObj destroy
} -body {
apply {{} {fooObj variable x; set x ok; return}}
apply {{} {fooObj variable x; return $x}}
} -result ok
test oo-20.14 {OO: variable method use in non-methods [Bug 2903811]} -setup {
oo::object create fooObj
oo::objdefine fooObj export variable
namespace eval ns1 {}
namespace eval ns2 {}
set x bad
} -cleanup {
fooObj destroy
namespace delete ns1 ns2
unset x
} -body {
namespace eval ns1 {fooObj variable x; set x ok; subst ""}
set x bad
namespace eval ns2 {fooObj variable x; return $x}
} -result ok
test oo-20.15 {OO: variable method use in non-methods [Bug 2903811]} -setup {
oo::object create fooObj
oo::objdefine fooObj export variable varname
} -cleanup {
fooObj destroy
} -body {
apply {{} {fooObj variable x; set x ok; return}}
return [set [fooObj varname x]]
} -result ok
test oo-21.1 {OO: inheritance ordering} -setup {
oo::class create A
} -body {
oo::define A method m {} {lappend ::result A}
oo::class create B {
superclass A
|
| ︙ | ︙ |
Changes to tests/safe.test.
1 2 | # safe.test -- # | | | | | | | | | < | | | | | | | | | | | | | | < | > | > | < | > | > < | | | > | > < | | > | > < | | > | > | < | > < | > < | | > | | > | | > | > | | | > | | > | > < | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 |
# safe.test --
#
# This file contains a collection of tests for safe Tcl, packages loading, and
# using safe interpreters. Sourcing this file into tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: safe.test,v 1.13.4.11 2009/12/08 18:39:20 dgp Exp $
package require Tcl 8.5
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
foreach i [interp slaves] {
interp delete $i
}
set saveAutoPath $::auto_path
set ::auto_path [info library]
# Force actual loading of the safe package because we use un exported (and
# thus un-autoindexed) APIs in this test result arguments:
catch {safe::interpConfigure}
proc equiv {x} {return $x}
test safe-1.1 {safe::interpConfigure syntax} -returnCodes error -body {
safe::interpConfigure
} -result {no value given for parameter "slave" (use -help for full usage) :
slave name () name of the slave}
test safe-1.2 {safe::interpCreate syntax} -returnCodes error -body {
safe::interpCreate -help
} -result {Usage information:
Var/FlagName Type Value Help
------------ ---- ----- ----
( -help gives this help )
?slave? name () name of the slave (optional)
-accessPath list () access path for the slave
-noStatics boolflag (false) prevent loading of statically linked pkgs
-statics boolean (true) loading of statically linked pkgs
-nestedLoadOk boolflag (false) allow nested loading
-nested boolean (false) nested loading
-deleteHook script () delete hook}
test safe-1.3 {safe::interpInit syntax} -returnCodes error -body {
safe::interpInit -noStatics
} -result {bad value "-noStatics" for parameter
slave name () name of the slave}
test safe-2.1 {creating interpreters, should have no aliases} emptyTest {
# Disabled this test. It tests nothing sensible. [Bug 999612]
# interp aliases
} ""
test safe-2.2 {creating interpreters, should have no aliases} -setup {
catch {safe::interpDelete a}
} -body {
interp create a
a aliases
} -cleanup {
safe::interpDelete a
} -result ""
test safe-2.3 {creating safe interpreters, should have no unexpected aliases} -setup {
catch {safe::interpDelete a}
} -body {
interp create a -safe
a aliases
} -cleanup {
interp delete a
} -result {clock}
test safe-3.1 {calling safe::interpInit is safe} -setup {
catch {safe::interpDelete a}
interp create a -safe
} -body {
safe::interpInit a
interp eval a exec ls
} -returnCodes error -cleanup {
safe::interpDelete a
} -result {invalid command name "exec"}
test safe-3.2 {calling safe::interpCreate on trusted interp} -setup {
catch {safe::interpDelete a}
} -body {
safe::interpCreate a
lsort [a aliases]
} -cleanup {
safe::interpDelete a
} -result {clock encoding exit file glob load source}
test safe-3.3 {calling safe::interpCreate on trusted interp} -setup {
catch {safe::interpDelete a}
} -body {
safe::interpCreate a
interp eval a {source [file join $tcl_library init.tcl]}
} -cleanup {
safe::interpDelete a
} -result ""
test safe-3.4 {calling safe::interpCreate on trusted interp} -setup {
catch {safe::interpDelete a}
} -body {
safe::interpCreate a
interp eval a {source [file join $tcl_library init.tcl]}
} -cleanup {
safe::interpDelete a
} -result {}
test safe-4.1 {safe::interpDelete} -setup {
catch {safe::interpDelete a}
} -body {
interp create a
safe::interpDelete a
} -result ""
test safe-4.2 {safe::interpDelete, indirectly} -setup {
catch {safe::interpDelete a}
} -body {
interp create a
a alias exit safe::interpDelete a
a eval exit
} -result ""
test safe-4.5 {safe::interpDelete} -setup {
catch {safe::interpDelete a}
} -body {
safe::interpCreate a
safe::interpCreate a
} -returnCodes error -cleanup {
safe::interpDelete a
} -result {interpreter named "a" already exists, cannot create}
test safe-4.6 {safe::interpDelete, indirectly} -setup {
catch {safe::interpDelete a}
} -body {
safe::interpCreate a
a eval exit
} -result ""
# The following test checks whether the definition of tcl_endOfWord can be
# obtained from auto_loading.
test safe-5.1 {test auto-loading in safe interpreters} -setup {
catch {safe::interpDelete a}
safe::interpCreate a
} -body {
interp eval a {tcl_endOfWord "" 0}
} -cleanup {
safe::interpDelete a
} -result -1
# test safe interps 'information leak'
proc SafeEval {script} {
# Helper procedure that ensures the safe interp is cleaned up even if
# there is a failure in the script.
set SafeInterp [interp create -safe]
catch {$SafeInterp eval $script} msg opts
|
| ︙ | ︙ | |||
194 195 196 197 198 199 200 |
# provided deep path)
list $token1 $token2 \
[catch {interp eval $i {package require http 1}} msg] $msg \
[safe::interpConfigure $i]\
[safe::interpDelete $i]
} -match glob -result "{\$p(:0:)} {\$p(:[expr 1+[llength [tcl::tm::list]]]:)} 1 {can't find package http 1} {-accessPath {[list $tcl_library * /dummy/unixlike/test/path]} -statics 0 -nested 1 -deleteHook {}} {}"
| < | | > | | | | | | | > | | < > | | | | < | | | > > | | | < | > | | | | < | | > > | | < | > | | | < < | > > > > > > | < < < | > | | | | > | | | | < | | > > | > | | | | > | | | < < | < | | > > > > | > | | | < | > | | | | | > | < > | | | | > | | | | | | > > > > | | | | < < | < | | | | > | | | | | | | < | | | | | | | | | | > | | < | | | | | | | < | < > | | | | | < > | | | < | < > | | | | | < > | | > > > > > > > | | | < > | | | | | | | | | | | | < < < < < < < | > > > > > > > | | | | | | | | | | < > | | | | | < > | | > > > > > > > | > > > > | 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 |
# provided deep path)
list $token1 $token2 \
[catch {interp eval $i {package require http 1}} msg] $msg \
[safe::interpConfigure $i]\
[safe::interpDelete $i]
} -match glob -result "{\$p(:0:)} {\$p(:[expr 1+[llength [tcl::tm::list]]]:)} 1 {can't find package http 1} {-accessPath {[list $tcl_library * /dummy/unixlike/test/path]} -statics 0 -nested 1 -deleteHook {}} {}"
# test source control on file name
test safe-8.1 {safe source control on file} -setup {
set i "a"
catch {safe::interpDelete $i}
} -body {
safe::interpCreate $i
$i eval {source}
} -returnCodes error -cleanup {
safe::interpDelete $i
} -result {wrong # args: should be "source ?-encoding E? fileName"}
test safe-8.2 {safe source control on file} -setup {
set i "a"
catch {safe::interpDelete $i}
} -body {
safe::interpCreate $i
$i eval {source a b c d e}
} -returnCodes error -cleanup {
safe::interpDelete $i
} -result {wrong # args: should be "source ?-encoding E? fileName"}
test safe-8.3 {safe source control on file} -setup {
set i "a"
catch {safe::interpDelete $i}
set log {}
proc safe-test-log {str} {lappend ::log $str}
set prevlog [safe::setLogCmd]
} -body {
safe::interpCreate $i
safe::setLogCmd safe-test-log
list [catch {$i eval {source .}} msg] $msg $log
} -cleanup {
safe::setLogCmd $prevlog
unset log
safe::interpDelete $i
} -result {1 {permission denied} {{ERROR for slave a : ".": is a directory}}}
test safe-8.4 {safe source control on file} -setup {
set i "a"
catch {safe::interpDelete $i}
set log {}
proc safe-test-log {str} {global log; lappend log $str}
set prevlog [safe::setLogCmd]
} -body {
safe::interpCreate $i;
safe::setLogCmd safe-test-log;
list [catch {$i eval {source /abc/def}} msg] $msg $log
} -cleanup {
safe::setLogCmd $prevlog
unset log
safe::interpDelete $i
} -result {1 {permission denied} {{ERROR for slave a : "/abc/def": not in access_path}}}
test safe-8.5 {safe source control on file} -setup {
set i "a"
catch {safe::interpDelete $i}
set log {}
proc safe-test-log {str} {global log; lappend log $str}
set prevlog [safe::setLogCmd]
} -body {
# This tested filename == *.tcl or tclIndex, but that restriction was
# removed in 8.4a4 - hobbs
safe::interpCreate $i
safe::setLogCmd safe-test-log
list [catch {
$i eval {source [file join [info lib] blah]}
} msg] $msg $log
} -cleanup {
safe::setLogCmd $prevlog
unset log
safe::interpDelete $i
} -result [list 1 {no such file or directory} [list "ERROR for slave a : [file join [info library] blah]:no such file or directory"]]
test safe-8.6 {safe source control on file} -setup {
set i "a"
catch {safe::interpDelete $i}
set log {}
proc safe-test-log {str} {global log; lappend log $str}
set prevlog [safe::setLogCmd]
} -body {
safe::interpCreate $i
safe::setLogCmd safe-test-log
list [catch {
$i eval {source [file join [info lib] blah.tcl]}
} msg] $msg $log
} -cleanup {
safe::setLogCmd $prevlog
unset log
safe::interpDelete $i
} -result [list 1 {no such file or directory} [list "ERROR for slave a : [file join [info library] blah.tcl]:no such file or directory"]]
test safe-8.7 {safe source control on file} -setup {
set i "a"
catch {safe::interpDelete $i}
set log {}
proc safe-test-log {str} {global log; lappend log $str}
set prevlog [safe::setLogCmd]
} -body {
safe::interpCreate $i
# This tested length of filename, but that restriction was removed in
# 8.4a4 - hobbs
safe::setLogCmd safe-test-log
list [catch {
$i eval {source [file join [info lib] xxxxxxxxxxx.tcl]}
} msg] $msg $log
} -cleanup {
safe::setLogCmd $prevlog
unset log
safe::interpDelete $i
} -result [list 1 {no such file or directory} [list "ERROR for slave a : [file join [info library] xxxxxxxxxxx.tcl]:no such file or directory"]]
test safe-8.8 {safe source forbids -rsrc} -setup {
set i "a"
catch {safe::interpDelete $i}
safe::interpCreate $i
} -body {
$i eval {source -rsrc Init}
} -returnCodes error -cleanup {
safe::interpDelete $i
} -result {wrong # args: should be "source ?-encoding E? fileName"}
test safe-9.1 {safe interps' deleteHook} -setup {
set i "a"
catch {safe::interpDelete $i}
set res {}
} -body {
proc testDelHook {args} {
global res
# the interp still exists at that point
interp eval a {set delete 1}
# mark that we've been here (successfully)
set res $args
}
safe::interpCreate $i -deleteHook "testDelHook arg1 arg2"
list [interp eval $i exit] $res
} -result {{} {arg1 arg2 a}}
test safe-9.2 {safe interps' error in deleteHook} -setup {
set i "a"
catch {safe::interpDelete $i}
set res {}
set log {}
proc safe-test-log {str} {lappend ::log $str}
set prevlog [safe::setLogCmd]
} -body {
proc testDelHook {args} {
global res
# the interp still exists at that point
interp eval a {set delete 1}
# mark that we've been here (successfully)
set res $args
# create an exception
error "being catched"
}
safe::interpCreate $i -deleteHook "testDelHook arg1 arg2"
safe::setLogCmd safe-test-log
list [safe::interpDelete $i] $res $log
} -cleanup {
safe::setLogCmd $prevlog
unset log
} -result {{} {arg1 arg2 a} {{NOTICE for slave a : About to delete} {ERROR for slave a : Delete hook error (being catched)} {NOTICE for slave a : Deleted}}}
test safe-9.3 {dual specification of statics} -returnCodes error -body {
safe::interpCreate -stat true -nostat
} -result {conflicting values given for -statics and -noStatics}
test safe-9.4 {dual specification of statics} {
# no error shall occur
safe::interpDelete [safe::interpCreate -stat false -nostat]
} {}
test safe-9.5 {dual specification of nested} -returnCodes error -body {
safe::interpCreate -nested 0 -nestedload
} -result {conflicting values given for -nested and -nestedLoadOk}
test safe-9.6 {interpConfigure widget like behaviour} -body {
# this test shall work, don't try to "fix it" unless you *really* know what
# you are doing (ie you are me :p) -- dl
list [set i [safe::interpCreate \
-noStatics \
-nestedLoadOk \
-deleteHook {foo bar}];
safe::interpConfigure $i -accessPath /foo/bar ;
safe::interpConfigure $i]\
[safe::interpConfigure $i -aCCess]\
[safe::interpConfigure $i -nested]\
[safe::interpConfigure $i -statics]\
[safe::interpConfigure $i -DEL]\
[safe::interpConfigure $i -accessPath /blah -statics 1;
safe::interpConfigure $i]\
[safe::interpConfigure $i -deleteHook toto -nosta -nested 0;
safe::interpConfigure $i]
} -match glob -result {{-accessPath * -statics 0 -nested 1 -deleteHook {foo bar}} {-accessPath *} {-nested 1} {-statics 0} {-deleteHook {foo bar}} {-accessPath * -statics 1 -nested 1 -deleteHook {foo bar}} {-accessPath * -statics 0 -nested 0 -deleteHook toto}}
# testing that nested and statics do what is advertised (we use a static
# package : Tcltest)
try {
package require Tcltest
testConstraint TcltestPackage 1
# we use the Tcltest package , which has no Safe_Init
} on error {} {
testConstraint TcltestPackage 0
}
teststaticpkg Safepkg1 0 0
test safe-10.1 {testing statics loading} -constraints TcltestPackage -setup {
set i [safe::interpCreate]
} -body {
interp eval $i {load {} Safepkg1}
} -returnCodes error -cleanup {
safe::interpDelete $i
} -result {can't use package in a safe interpreter: no Safepkg1_SafeInit procedure}
test safe-10.2 {testing statics loading / -nostatics} -constraints TcltestPackage -body {
set i [safe::interpCreate -nostatics]
interp eval $i {load {} Safepkg1}
} -returnCodes error -cleanup {
safe::interpDelete $i
} -result {permission denied (static package)}
test safe-10.3 {testing nested statics loading / no nested by default} -setup {
set i [safe::interpCreate]
} -constraints TcltestPackage -body {
interp eval $i {interp create x; load {} Safepkg1 x}
} -returnCodes error -cleanup {
safe::interpDelete $i
} -result {permission denied (nested load)}
test safe-10.4 {testing nested statics loading / -nestedloadok} -constraints TcltestPackage -body {
set i [safe::interpCreate -nestedloadok]
interp eval $i {interp create x; load {} Safepkg1 x}
} -returnCodes error -cleanup {
safe::interpDelete $i
} -result {can't use package in a safe interpreter: no Safepkg1_SafeInit procedure}
test safe-11.1 {testing safe encoding} -setup {
set i [safe::interpCreate]
} -body {
interp eval $i encoding
} -returnCodes error -cleanup {
safe::interpDelete $i
} -result {wrong # args: should be "encoding option ?arg ...?"}
test safe-11.1a {testing safe encoding} -setup {
set i [safe::interpCreate]
} -body {
interp eval $i encoding foobar
} -returnCodes error -cleanup {
safe::interpDelete $i
} -match glob -result {bad option "foobar": must be *}
test safe-11.2 {testing safe encoding} -setup {
set i [safe::interpCreate]
} -body {
interp eval $i encoding system cp775
} -returnCodes error -cleanup {
safe::interpDelete $i
} -result {wrong # args: should be "encoding system"}
test safe-11.3 {testing safe encoding} -setup {
set i [safe::interpCreate]
} -body {
interp eval $i encoding system
} -cleanup {
safe::interpDelete $i
} -result [encoding system]
test safe-11.4 {testing safe encoding} -setup {
set i [safe::interpCreate]
} -body {
interp eval $i encoding names
} -cleanup {
safe::interpDelete $i
} -result [encoding names]
test safe-11.5 {testing safe encoding} -setup {
set i [safe::interpCreate]
} -body {
interp eval $i encoding convertfrom cp1258 foobar
} -cleanup {
safe::interpDelete $i
} -result foobar
test safe-11.6 {testing safe encoding} -setup {
set i [safe::interpCreate]
} -body {
interp eval $i encoding convertto cp1258 foobar
} -cleanup {
safe::interpDelete $i
} -result foobar
test safe-11.7 {testing safe encoding} -setup {
set i [safe::interpCreate]
} -body {
interp eval $i encoding convertfrom
} -returnCodes error -cleanup {
safe::interpDelete $i
} -result {wrong # args: should be "encoding convertfrom ?encoding? data"}
test safe-11.8 {testing safe encoding} -setup {
set i [safe::interpCreate]
} -body {
interp eval $i encoding convertto
} -returnCodes error -cleanup {
safe::interpDelete $i
} -result {wrong # args: should be "encoding convertto ?encoding? data"}
test safe-12.1 {glob is restricted [Bug 2906841]} -setup {
set i [safe::interpCreate]
} -body {
$i eval glob ../*
} -returnCodes error -cleanup {
safe::interpDelete $i
} -result "permission denied"
set ::auto_path $saveAutoPath
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to tests/tailcall.test.
1 2 3 4 5 6 7 8 9 10 11 | # Commands covered: tailcall # # This file contains a collection of tests for experimental commands that are # found in ::tcl::unsupported. The tests will migrate to normal test files # if/when the commands find their way into the core. # # Copyright (c) 2008 by Miguel Sofer. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | < < < < < < < < < < < < < < < < < < > > > > > > > > < > > > < > > > < > > > < > > > < > > > < > > > < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 |
# Commands covered: tailcall
#
# This file contains a collection of tests for experimental commands that are
# found in ::tcl::unsupported. The tests will migrate to normal test files
# if/when the commands find their way into the core.
#
# Copyright (c) 2008 by Miguel Sofer.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: tailcall.test,v 1.1.2.7 2009/12/08 18:39:20 dgp Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint testnrelevels [llength [info commands testnrelevels]]
#
# The tests that risked blowing the C stack on failure have been removed: we
# can now actually measure using testnrelevels.
#
if {[testConstraint testnrelevels]} {
namespace eval testnre {
#
# [testnrelevels] returns a 6-list with: C-stack depth, iPtr->numlevels,
# cmdFrame level, callFrame level, tosPtr and callback depth
#
variable last [testnrelevels]
proc depthDiff {} {
variable last
set depth [testnrelevels]
set res {}
foreach t $depth l $last {
lappend res [expr {$t-$l}]
}
set last $depth
return $res
}
namespace export *
}
namespace import testnre::*
}
test tailcall-0.1 {tailcall is constant space} -constraints testnrelevels -setup {
proc a i {
#
# NOTE: there may be a diff in callback depth with the first call
# ($i==0) due to the fact that the first is from an eval. Successive
# calls should add nothing to any stack depths.
#
if {$i == 1} {
depthDiff
}
if {[incr i] > 10} {
return [depthDiff]
}
tailcall a $i
}
} -body {
a 0
} -cleanup {
rename a {}
} -result {0 0 0 0 0 0}
test tailcall-0.2 {tailcall is constant space} -constraints testnrelevels -setup {
set a { i {
if {$i == 1} {
depthDiff
}
if {[incr i] > 10} {
return [depthDiff]
}
upvar 1 a a
tailcall apply $a $i
}}
} -body {
apply $a 0
} -cleanup {
unset a
} -result {0 0 0 0 0 0}
test tailcall-0.3 {tailcall is constant space} -constraints testnrelevels -setup {
proc a i {
if {$i == 1} {
depthDiff
}
if {[incr i] > 10} {
return [depthDiff]
}
tailcall b $i
}
interp alias {} b {} a
} -body {
b 0
} -cleanup {
rename a {}
rename b {}
} -result {0 0 0 0 0 0}
test tailcall-0.4 {tailcall is constant space} -constraints testnrelevels -setup {
namespace eval ::ns {
namespace export *
}
proc ::ns::a i {
if {$i == 1} {
depthDiff
}
if {[incr i] > 10} {
return [depthDiff]
}
set b [uplevel 1 [list namespace which b]]
tailcall $b $i
}
namespace import ::ns::a
rename a b
} -body {
b 0
} -cleanup {
rename b {}
namespace delete ::ns
} -result {0 0 0 0 0 0}
test tailcall-0.5 {tailcall is constant space} -constraints testnrelevels -setup {
proc b i {
if {$i == 1} {
depthDiff
}
if {[incr i] > 10} {
return [depthDiff]
}
tailcall a b $i
}
namespace ensemble create -command a -map {b b}
} -body {
a b 0
} -cleanup {
rename a {}
rename b {}
} -result {0 0 0 0 0 0}
test tailcall-0.6 {tailcall is constant space} -constraints {testnrelevels knownBug} -setup {
#
# This test fails because ns-unknown is not NR-enabled
#
proc c i {
if {$i == 1} {
depthDiff
}
if {[incr i] > 10} {
return [depthDiff]
}
tailcall a b $i
}
proc d {ens sub args} {
return [list $ens c]
}
namespace ensemble create -command a -unknown d
} -body {
a b 0
} -cleanup {
rename a {}
rename c {}
rename d {}
} -result {0 0 0 0 0 0}
test tailcall-0.7 {tailcall is constant space} -constraints testnrelevels -setup {
catch {rename foo {}}
oo::class create foo {
method b i {
if {$i == 1} {
depthDiff
}
if {[incr i] > 10} {
return [depthDiff]
}
tailcall [self] b $i
}
}
} -body {
foo create a
a b 0
} -cleanup {
|
| ︙ | ︙ | |||
555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 |
list [catch {tailcall foo} msg] $msg
}
} -body {
a
} -cleanup {
rename a {}
} -result {1 {Tailcall called from within a catch environment}}
if {[testConstraint testnrelevels]} {
namespace forget testnre::*
namespace delete testnre
}
# cleanup
::tcltest::cleanupTests
| > > > > > > > > > > > > > > > > > | 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 |
list [catch {tailcall foo} msg] $msg
}
} -body {
a
} -cleanup {
rename a {}
} -result {1 {Tailcall called from within a catch environment}}
test tailcall-13.1 {tailcall and coroutine} -setup {
set lambda {i {
if {$i == 1} {
depthDiff
}
if {[incr i] > 10} {
return [depthDiff]
}
tailcall coroutine foo ::apply $::lambda $i
}}
} -body {
coroutine moo ::apply $::lambda 0
} -cleanup {
unset lambda
} -result {0 0 0 0 0 0}
if {[testConstraint testnrelevels]} {
namespace forget testnre::*
namespace delete testnre
}
# cleanup
::tcltest::cleanupTests
|
Changes to tools/genStubs.tcl.
1 2 3 4 5 6 7 8 9 10 11 12 | # genStubs.tcl -- # # This script generates a set of stub files for a given # interface. # # # Copyright (c) 1998-1999 by Scriptics Corporation. # Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net> # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
# genStubs.tcl --
#
# This script generates a set of stub files for a given
# interface.
#
#
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net>
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: genStubs.tcl,v 1.15.2.12 2009/12/08 18:39:20 dgp Exp $
package require Tcl 8.4
namespace eval genStubs {
# libraryName --
#
# The name of the entire library. This value is used to compute
|
| ︙ | ︙ | |||
499 500 501 502 503 504 505 |
return $text
}
append text " \\\n\t(${name}StubsPtr->$lfname)"
append text " /* $index */\n#endif\n"
return $text
}
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 499 500 501 502 503 504 505 506 507 508 509 510 511 512 |
return $text
}
append text " \\\n\t(${name}StubsPtr->$lfname)"
append text " /* $index */\n#endif\n"
return $text
}
# genStubs::makeSlot --
#
# Generate the stub table entry for a function.
#
# Arguments:
# name The interface name.
# decl The function declaration.
|
| ︙ | ︙ | |||
587 588 589 590 591 592 593 |
append lfname [string range $fname 1 end]
set text " "
if {$args == ""} {
append text $rtype " *" $lfname "; /* $index */\n"
return $text
}
| > > > | | | 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 |
append lfname [string range $fname 1 end]
set text " "
if {$args == ""} {
append text $rtype " *" $lfname "; /* $index */\n"
return $text
}
if {[string range $rtype end-7 end] == "CALLBACK"} {
append text [string trim [string range $rtype 0 end-8]] " (CALLBACK *" $lfname ") "
} else {
append text $rtype " (*" $lfname ") "
}
set arg1 [lindex $args 0]
switch -exact $arg1 {
void {
append text "(void)"
}
TCL_VARARGS {
set sep "("
|
| ︙ | ︙ | |||
1004 1005 1006 1007 1008 1009 1010 |
emitMacros $name text
rewriteFile [file join $outDir ${name}Decls.h] $text
return
}
| < < < < < < < < < < < < < < < < < < < < < | 942 943 944 945 946 947 948 949 950 951 952 953 954 955 |
emitMacros $name text
rewriteFile [file join $outDir ${name}Decls.h] $text
return
}
# genStubs::emitInit --
#
# Generate the table initializers for an interface.
#
# Arguments:
# name The name of the interface to initialize.
# textVar The variable to use for output.
|
| ︙ | ︙ |
Changes to unix/Makefile.in.
1 2 3 4 5 6 | # # This file is a Makefile for Tcl. If it has the name "Makefile.in" then it is # a template for a Makefile; to generate the actual Makefile, run # "./configure", which is a configuration script generated by the "autoconf" # program (constructs like "@foo@" will get replaced in the actual Makefile. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | # # This file is a Makefile for Tcl. If it has the name "Makefile.in" then it is # a template for a Makefile; to generate the actual Makefile, run # "./configure", which is a configuration script generated by the "autoconf" # program (constructs like "@foo@" will get replaced in the actual Makefile. # # RCS: @(#) $Id: Makefile.in,v 1.127.2.82 2009/12/08 18:39:20 dgp Exp $ VERSION = @TCL_VERSION@ MAJOR_VERSION = @TCL_MAJOR_VERSION@ MINOR_VERSION = @TCL_MINOR_VERSION@ PATCH_LEVEL = @TCL_PATCH_LEVEL@ #-------------------------------------------------------------------------- |
| ︙ | ︙ | |||
452 453 454 455 456 457 458 | $(GENERIC_DIR)/tclOOCall.c \ $(GENERIC_DIR)/tclOODefineCmds.c \ $(GENERIC_DIR)/tclOOInfo.c \ $(GENERIC_DIR)/tclOOMethod.c \ $(GENERIC_DIR)/tclOOStubInit.c STUB_SRCS = \ | | > | 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 | $(GENERIC_DIR)/tclOOCall.c \ $(GENERIC_DIR)/tclOODefineCmds.c \ $(GENERIC_DIR)/tclOOInfo.c \ $(GENERIC_DIR)/tclOOMethod.c \ $(GENERIC_DIR)/tclOOStubInit.c STUB_SRCS = \ $(GENERIC_DIR)/tclStubLib.c \ $(GENERIC_DIR)/tclOOStubLib.o TOMMATH_SRCS = \ $(TOMMATH_DIR)/bncore.c \ $(TOMMATH_DIR)/bn_reverse.c \ $(TOMMATH_DIR)/bn_fast_s_mp_mul_digs.c \ $(TOMMATH_DIR)/bn_fast_s_mp_sqr.c \ $(TOMMATH_DIR)/bn_mp_add.c \ |
| ︙ | ︙ | |||
562 563 564 565 566 567 568 | DTRACE_SRC = $(GENERIC_DIR)/tclDTrace.d ZLIB_SRCS = \ $(ZLIB_DIR)/adler32.c \ $(ZLIB_DIR)/compress.c \ $(ZLIB_DIR)/crc32.c \ $(ZLIB_DIR)/deflate.c \ | < > > > > | 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 |
DTRACE_SRC = $(GENERIC_DIR)/tclDTrace.d
ZLIB_SRCS = \
$(ZLIB_DIR)/adler32.c \
$(ZLIB_DIR)/compress.c \
$(ZLIB_DIR)/crc32.c \
$(ZLIB_DIR)/deflate.c \
$(ZLIB_DIR)/infback.c \
$(ZLIB_DIR)/inffast.c \
$(ZLIB_DIR)/inflate.c \
$(ZLIB_DIR)/inftrees.c \
$(ZLIB_DIR)/trees.c \
$(ZLIB_DIR)/uncompr.c \
$(ZLIB_DIR)/zutil.c
# Note: don't include DL_SRCS or MAC_OSX_SRCS in SRCS: most of those files
# won't compile on the current machine, and they will cause problems for
# things like "make depend".
SRCS = $(GENERIC_SRCS) $(TOMMATH_SRCS) $(UNIX_SRCS) $(NOTIFY_SRCS) \
$(OO_SRCS) $(STUB_SRCS) @PLAT_SRCS@ @ZLIB_SRCS@
#--------------------------------------------------------------------------
# Start of rules
#--------------------------------------------------------------------------
all: binaries libraries doc packages
binaries: ${LIB_FILE} $(STUB_LIB_FILE) $(TCL_BUILD_EXP_FILE) tclsh
libraries:
|
| ︙ | ︙ | |||
606 607 608 609 610 611 612 |
# The dependency on OBJS is not there because we just want the list of objects
# here, not actually building them
tclLibObjs:
@echo ${OBJS}
# This targets actually build the objects needed for the lib in the above case
objs: ${OBJS}
| < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 |
# The dependency on OBJS is not there because we just want the list of objects
# here, not actually building them
tclLibObjs:
@echo ${OBJS}
# This targets actually build the objects needed for the lib in the above case
objs: ${OBJS}
tclsh: ${TCLSH_OBJS} ${TCL_LIB_FILE}
${CC} ${CFLAGS} ${LDFLAGS} ${TCLSH_OBJS} @TCL_BUILD_LIB_SPEC@ ${LIBS} @EXTRA_TCLSH_LIBS@ \
${CC_SEARCH_FLAGS} -o tclsh
Makefile: $(UNIX_DIR)/Makefile.in $(DLTEST_DIR)/Makefile.in
$(SHELL) config.status
#tclConfig.h: $(UNIX_DIR)/tclConfig.h.in
# $(SHELL) config.status
clean: clean-packages
rm -f *.a *.o libtcl* core errs *~ \#* TAGS *.E a.out \
errors tclsh tcltest lib.exp Tcl @DTRACE_HDR@
cd dltest ; $(MAKE) clean
distclean: distclean-packages clean
rm -rf Makefile config.status config.cache config.log tclConfig.sh \
tclConfig.h *.plist Tcl.framework tcl.pc
cd dltest ; $(MAKE) distclean
depend:
makedepend -- $(DEPEND_SWITCHES) -- $(SRCS)
#--------------------------------------------------------------------------
# The following target outputs the name of the top-level source directory for
# Tcl (it is used by Tk's configure script, for example). The .NO_PARALLEL
# line is needed to avoid problems under Sun's "pmake". Note: this target is
# now obsolete (use the autoconf variable TCL_SRC_DIR from tclConfig.sh
# instead).
#--------------------------------------------------------------------------
.NO_PARALLEL: topDirName
topDirName:
@cd $(TOP_DIR); pwd
#--------------------------------------------------------------------------
# Rules for testing
#--------------------------------------------------------------------------
# Resetting the LIB_RUNTIME_DIR below is required so that the generated
# tcltest executable gets the build directory burned into its ld search path.
# This keeps tcltest from picking up an already installed version of the Tcl
# library.
SHELL_ENV = @LD_LIBRARY_PATH_VAR@=`pwd`:${@LD_LIBRARY_PATH_VAR@} \
TCLLIBPATH="@abs_builddir@/pkgs" \
TCL_LIBRARY="${TCL_BUILDTIME_LIBRARY}"
|
| ︙ | ︙ | |||
655 656 657 658 659 660 661 662 663 664 665 666 667 668 | $(SHELL_ENV) ./tcltest # Useful target for running the test suite with an unwritable current # directory... ro-test: tcltest echo 'exec chmod -w .;package require tcltest;tcltest::temporaryDirectory /tmp;source ../tests/all.tcl;exec chmod +w .' | $(SHELL_ENV) ./tcltest # This target can be used to run tclsh from the build directory # via `make shell SCRIPT=/tmp/foo.tcl` shell: tclsh $(SHELL_ENV) ./tclsh $(SCRIPT) # This target can be used to run tclsh inside either gdb or insight gdb: tclsh | > > > > > > > > > > > > > | 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 |
$(SHELL_ENV) ./tcltest
# Useful target for running the test suite with an unwritable current
# directory...
ro-test: tcltest
echo 'exec chmod -w .;package require tcltest;tcltest::temporaryDirectory /tmp;source ../tests/all.tcl;exec chmod +w .' | $(SHELL_ENV) ./tcltest
# The following target generates the shared libraries in dltest/ that are used
# for testing; they are included as part of the "tcltest" target (via the
# BUILD_DLTEST variable) if dynamic loading is supported on this platform. The
# Makefile in the dltest subdirectory creates the dltest.marker file in this
# directory after a successful build.
dltest.marker: ${STUB_LIB_FILE}
cd dltest ; $(MAKE)
#--------------------------------------------------------------------------
# Rules for running a shell before installation
#--------------------------------------------------------------------------
# This target can be used to run tclsh from the build directory
# via `make shell SCRIPT=/tmp/foo.tcl`
shell: tclsh
$(SHELL_ENV) ./tclsh $(SCRIPT)
# This target can be used to run tclsh inside either gdb or insight
gdb: tclsh
|
| ︙ | ︙ | |||
676 677 678 679 680 681 682 | valgrind: tclsh tcltest $(SHELL_ENV) valgrind $(VALGRINDARGS) ./tcltest $(TOP_DIR)/tests/all.tcl -singleproc 1 $(TESTFLAGS) valgrindshell: tclsh $(SHELL_ENV) valgrind $(VALGRINDARGS) ./tclsh $(SCRIPT) | < < < < < | < < < | < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 | valgrind: tclsh tcltest $(SHELL_ENV) valgrind $(VALGRINDARGS) ./tcltest $(TOP_DIR)/tests/all.tcl -singleproc 1 $(TESTFLAGS) valgrindshell: tclsh $(SHELL_ENV) valgrind $(VALGRINDARGS) ./tclsh $(SCRIPT) #-------------------------------------------------------------------------- # Installation rules #-------------------------------------------------------------------------- INSTALL_TARGETS = install-binaries install-libraries install-doc install-packages @EXTRA_INSTALL@ install: $(INSTALL_TARGETS) install-strip: $(MAKE) $(INSTALL_TARGETS) \ |
| ︙ | ︙ | |||
911 912 913 914 915 916 917 | do \ $(INSTALL_DATA) $$i "$(PRIVATE_INCLUDE_INSTALL_DIR)"; \ done; @if test -f tclConfig.h; then\ $(INSTALL_DATA) tclConfig.h "$(PRIVATE_INCLUDE_INSTALL_DIR)"; \ fi; | < < < < | < < < < | < < < < | < < | 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 | do \ $(INSTALL_DATA) $$i "$(PRIVATE_INCLUDE_INSTALL_DIR)"; \ done; @if test -f tclConfig.h; then\ $(INSTALL_DATA) tclConfig.h "$(PRIVATE_INCLUDE_INSTALL_DIR)"; \ fi; #-------------------------------------------------------------------------- # Rules for how to compile C files #-------------------------------------------------------------------------- # Test binaries. The rules for tclTestInit.o and xtTestInit.o are complicated # because they are compiled from tclAppInit.c. Can't use the "-o" option # because this doesn't work on some strange compilers (e.g. UnixWare). # # To enable concurrent parallel make of tclsh and tcltest resp xttest, these # targets have to depend on tclsh, this ensures that linking of tclsh with |
| ︙ | ︙ | |||
1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 |
$(DTRACE_HDR): $(DTRACE_SRC)
$(DTRACE) -h $(DTRACE_SWITCHES) -o $@ -s $(DTRACE_SRC)
$(DTRACE_OBJ): $(DTRACE_SRC) $(TCL_OBJS)
$(DTRACE) -G $(DTRACE_SWITCHES) -o $@ -s $(DTRACE_SRC) $(TCL_OBJS)
# The following targets are not completely general. They are provide purely
# for documentation purposes so people who are interested in the Xt based
# notifier can modify them to suit their own installation.
xttest: ${XTTEST_OBJS} ${GENERIC_OBJS} ${UNIX_OBJS} ${COMPAT_OBJS} ${TCL_STUB_LIB_FILE} \
@DL_OBJS@ ${BUILD_DLTEST}
${CC} ${XTTEST_OBJS} ${GENERIC_OBJS} ${UNIX_OBJS} ${COMPAT_OBJS} ${TCL_STUB_LIB_FILE} \
@DL_OBJS@ @TCL_BUILD_LIB_SPEC@ ${LIBS} \
${CC_SEARCH_FLAGS} -L/usr/openwin/lib -lXt -o xttest
tclXtNotify.o: $(UNIX_DIR)/tclXtNotify.c
$(CC) -c $(APP_CC_SWITCHES) -I/usr/openwin/include \
$(UNIX_DIR)/tclXtNotify.c
tclXtTest.o: $(UNIX_DIR)/tclXtTest.c
$(CC) -c $(APP_CC_SWITCHES) -I/usr/openwin/include \
$(UNIX_DIR)/tclXtTest.c
# Compat binaries, these must be compiled for use in a shared library even
# though they may be placed in a static executable or library. Since they are
# included in both the tcl library and the stub library, they need to be
# relocatable.
fixstrtod.o: $(COMPAT_DIR)/fixstrtod.c
$(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/fixstrtod.c
opendir.o: $(COMPAT_DIR)/opendir.c
$(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/opendir.c
| > > > > | 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 |
$(DTRACE_HDR): $(DTRACE_SRC)
$(DTRACE) -h $(DTRACE_SWITCHES) -o $@ -s $(DTRACE_SRC)
$(DTRACE_OBJ): $(DTRACE_SRC) $(TCL_OBJS)
$(DTRACE) -G $(DTRACE_SWITCHES) -o $@ -s $(DTRACE_SRC) $(TCL_OBJS)
#--------------------------------------------------------------------------
# The following targets are not completely general. They are provide purely
# for documentation purposes so people who are interested in the Xt based
# notifier can modify them to suit their own installation.
#--------------------------------------------------------------------------
xttest: ${XTTEST_OBJS} ${GENERIC_OBJS} ${UNIX_OBJS} ${COMPAT_OBJS} ${TCL_STUB_LIB_FILE} \
@DL_OBJS@ ${BUILD_DLTEST}
${CC} ${XTTEST_OBJS} ${GENERIC_OBJS} ${UNIX_OBJS} ${COMPAT_OBJS} ${TCL_STUB_LIB_FILE} \
@DL_OBJS@ @TCL_BUILD_LIB_SPEC@ ${LIBS} \
${CC_SEARCH_FLAGS} -L/usr/openwin/lib -lXt -o xttest
tclXtNotify.o: $(UNIX_DIR)/tclXtNotify.c
$(CC) -c $(APP_CC_SWITCHES) -I/usr/openwin/include \
$(UNIX_DIR)/tclXtNotify.c
tclXtTest.o: $(UNIX_DIR)/tclXtTest.c
$(CC) -c $(APP_CC_SWITCHES) -I/usr/openwin/include \
$(UNIX_DIR)/tclXtTest.c
#--------------------------------------------------------------------------
# Compat binaries, these must be compiled for use in a shared library even
# though they may be placed in a static executable or library. Since they are
# included in both the tcl library and the stub library, they need to be
# relocatable.
#--------------------------------------------------------------------------
fixstrtod.o: $(COMPAT_DIR)/fixstrtod.c
$(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/fixstrtod.c
opendir.o: $(COMPAT_DIR)/opendir.c
$(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/opendir.c
|
| ︙ | ︙ | |||
1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 | Ztrees.o: $(ZLIB_DIR)/trees.c $(CC) -c -o $@ $(CC_SWITCHES) -I$(ZLIB_DIR) $(ZLIB_DIR)/trees.c Zuncompr.o: $(ZLIB_DIR)/uncompr.c $(CC) -c -o $@ $(CC_SWITCHES) -I$(ZLIB_DIR) $(ZLIB_DIR)/uncompr.c Zzutil.o: $(ZLIB_DIR)/zutil.c $(CC) -c -o $@ $(CC_SWITCHES) -I$(ZLIB_DIR) $(ZLIB_DIR)/zutil.c # Stub library binaries, these must be compiled for use in a shared library # even though they will be placed in a static archive tclStubLib.o: $(GENERIC_DIR)/tclStubLib.c $(CC) -c $(STUB_CC_SWITCHES) $(GENERIC_DIR)/tclStubLib.c tclOOStubLib.o: $(GENERIC_DIR)/tclOOStubLib.c $(CC) -c $(STUB_CC_SWITCHES) $(GENERIC_DIR)/tclOOStubLib.c .c.o: $(CC) -c $(CC_SWITCHES) $< | > > | | | 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 | Ztrees.o: $(ZLIB_DIR)/trees.c $(CC) -c -o $@ $(CC_SWITCHES) -I$(ZLIB_DIR) $(ZLIB_DIR)/trees.c Zuncompr.o: $(ZLIB_DIR)/uncompr.c $(CC) -c -o $@ $(CC_SWITCHES) -I$(ZLIB_DIR) $(ZLIB_DIR)/uncompr.c Zzutil.o: $(ZLIB_DIR)/zutil.c $(CC) -c -o $@ $(CC_SWITCHES) -I$(ZLIB_DIR) $(ZLIB_DIR)/zutil.c #-------------------------------------------------------------------------- # Stub library binaries, these must be compiled for use in a shared library # even though they will be placed in a static archive #-------------------------------------------------------------------------- tclStubLib.o: $(GENERIC_DIR)/tclStubLib.c $(CC) -c $(STUB_CC_SWITCHES) $(GENERIC_DIR)/tclStubLib.c tclOOStubLib.o: $(GENERIC_DIR)/tclOOStubLib.c $(CC) -c $(STUB_CC_SWITCHES) $(GENERIC_DIR)/tclOOStubLib.c .c.o: $(CC) -c $(CC_SWITCHES) $< #-------------------------------------------------------------------------- # Bundled Package targets #-------------------------------------------------------------------------- # propagate configure args like --enable-64bit to package configure PKG_CFG_ARGS = @PKG_CFG_ARGS@ # if PKG_DIR is changed to a different relative depth to the build dir, # need to adapt the ../.. relative paths below and at the top of configure.in # (cannot use absolute paths due to issues in nested configure when path to # build dir contains spaces). |
| ︙ | ︙ | |||
1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 | if [ -f $(PKG_DIR)/$$pkg/Makefile ]; then \ ( cd $(PKG_DIR)/$$pkg; $(MAKE) dist \ "DIST_ROOT=$(DISTROOT)/pkgs"; ) || exit $$?; \ fi; \ fi; \ done # # Target to regenerate header files and stub files from the *.decls tables. # $(GENERIC_DIR)/tclStubInit.c: $(GENERIC_DIR)/tcl.decls \ $(GENERIC_DIR)/tclInt.decls $(GENERIC_DIR)/tclTomMath.decls @echo "Warning: tclStubInit.c may be out of date." | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 | if [ -f $(PKG_DIR)/$$pkg/Makefile ]; then \ ( cd $(PKG_DIR)/$$pkg; $(MAKE) dist \ "DIST_ROOT=$(DISTROOT)/pkgs"; ) || exit $$?; \ fi; \ fi; \ done #-------------------------------------------------------------------------- # Maintainer-only targets #-------------------------------------------------------------------------- # The following target generates the file generic/tclDate.c from the yacc # grammar found in generic/tclGetDate.y. This is only run by hand as yacc is # not available in all environments. The name of the .c file is different than # the name of the .y file so that make doesn't try to automatically regenerate # the .c file. gendate: bison --output-file=$(GENERIC_DIR)/tclDate.c \ --no-lines \ --name-prefix=TclDate \ $(GENERIC_DIR)/tclGetDate.y # yacc -l $(GENERIC_DIR)/tclGetDate.y # sed -e 's/yy/TclDate/g' -e '/^#include <values.h>/d' \ # -e 's?SCCSID?RCS: @(#) ?' \ # -e '/#ifdef __STDC__/,/#endif/d' -e '/TclDateerrlab:/d' \ # -e '/TclDatenewstate:/d' -e '/#pragma/d' \ # -e '/#include <inttypes.h>/d' -e 's/const /CONST /g' \ # -e '/#define YYNEW/s/malloc/TclDateAlloc/g' \ # -e '/#define YYENLARGE/,/realloc/s/realloc/TclDateRealloc/g' \ # <y.tab.c >$(GENERIC_DIR)/tclDate.c # rm y.tab.c # The following target generates the file generic/tclTomMath.h. It needs to be # run (and the results checked) after updating to a new release of libtommath. gentommath_h: $(TCL_EXE) "$(TOOL_DIR)/fix_tommath_h.tcl" \ "$(TOMMATH_DIR)/tommath.h" \ > "$(GENERIC_DIR)/tclTomMath.h" # # Target to regenerate header files and stub files from the *.decls tables. # $(GENERIC_DIR)/tclStubInit.c: $(GENERIC_DIR)/tcl.decls \ $(GENERIC_DIR)/tclInt.decls $(GENERIC_DIR)/tclTomMath.decls @echo "Warning: tclStubInit.c may be out of date." |
| ︙ | ︙ | |||
1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 |
# Target to make sure that only symbols with "Tcl" prefixes are exported.
#
checkexports: $(TCL_LIB_FILE)
-@nm -p $(TCL_LIB_FILE) \
| awk '$$2 ~ /^[TDBCS]$$/ { sub("^_", "", $$3); print $$3 }' \
| sort -n | grep -E -v '^[Tt]cl' || true
#
# Target to create a Tcl RPM for Linux. Requires that you be on a Linux
# system.
#
rpm: all /bin/rpm
| > > > > | 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 |
# Target to make sure that only symbols with "Tcl" prefixes are exported.
#
checkexports: $(TCL_LIB_FILE)
-@nm -p $(TCL_LIB_FILE) \
| awk '$$2 ~ /^[TDBCS]$$/ { sub("^_", "", $$3); print $$3 }' \
| sort -n | grep -E -v '^[Tt]cl' || true
#--------------------------------------------------------------------------
# Distribution building rules
#--------------------------------------------------------------------------
#
# Target to create a Tcl RPM for Linux. Requires that you be on a Linux
# system.
#
rpm: all /bin/rpm
|
| ︙ | ︙ | |||
1960 1961 1962 1963 1964 1965 1966 |
mv $(DISTROOT)/tcl${VERSION} $(DISTROOT)/old
mv $(DISTROOT)/$(DISTNAME) $(DISTROOT)/tcl${VERSION}
cd $(DISTROOT); tar cf $(DISTNAME)-src.tar tcl${VERSION}; \
gzip -9 $(DISTNAME)-src.tar; zip -r8 $(ZIPNAME) tcl${VERSION}
mv $(DISTROOT)/tcl${VERSION} $(DISTROOT)/$(DISTNAME)
mv $(DISTROOT)/old $(DISTROOT)/tcl${VERSION}
| | > > > > > > > > > > > > > > > > > > > > | 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 |
mv $(DISTROOT)/tcl${VERSION} $(DISTROOT)/old
mv $(DISTROOT)/$(DISTNAME) $(DISTROOT)/tcl${VERSION}
cd $(DISTROOT); tar cf $(DISTNAME)-src.tar tcl${VERSION}; \
gzip -9 $(DISTNAME)-src.tar; zip -r8 $(ZIPNAME) tcl${VERSION}
mv $(DISTROOT)/tcl${VERSION} $(DISTROOT)/$(DISTNAME)
mv $(DISTROOT)/old $(DISTROOT)/tcl${VERSION}
#--------------------------------------------------------------------------
# This target creates the HTML folder for Tcl & Tk and places it in
# DISTDIR/html. It uses the tcltk-man2html.tcl tool from the Tcl group's tool
# workspace. It depends on the Tcl & Tk being in directories called tcl8.* &
# tk8.* up two directories from the TOOL_DIR.
#
# Note that for platforms where this is important, it is more common to use a
# build of this HTML documentation that has already been placed online. As
# such, this rule is not guaranteed to work well on all systems; it only needs
# to function on those of the Tcl/Tk maintainers.
#--------------------------------------------------------------------------
html: tclsh
$(BUILD_HTML)
@EXTRA_BUILD_HTML@
html-tcl: tclsh
$(BUILD_HTML) --tcl
@EXTRA_BUILD_HTML@
html-tk: tclsh
$(BUILD_HTML) --tk
@EXTRA_BUILD_HTML@
BUILD_HTML = \
@@LD_LIBRARY_PATH_VAR@="`pwd`:$${@LD_LIBRARY_PATH_VAR@}"; export @LD_LIBRARY_PATH_VAR@; \
TCL_LIBRARY="${TCL_BUILDTIME_LIBRARY}"; export TCL_LIBRARY; \
./tclsh $(TOOL_DIR)/tcltk-man2html.tcl --htmldir="$(HTML_INSTALL_DIR)" \
--srcdir=$(TOP_DIR)/.. $(BUILD_HTML_FLAGS)
#--------------------------------------------------------------------------
# The list of all the targets that do not correspond to real files. This stops
# 'make' from getting confused when someone makes an error in a rule.
#--------------------------------------------------------------------------
.PHONY: all binaries libraries doc packages tclLibObjs objs tcltest-real test
.PHONY: test-tcl gdb-test runtest ro-test shell gdb ddd valgrind valgrindshell
.PHONY: topDirName gendate gentommath_h install install-strip install-binaries
.PHONY: install-libraries install-tzdata install-msgs install-doc clean dist
.PHONY: install-private-headers distclean depend xttest configure-packages rpm
.PHONY: packages install-packages test-packages clean-packages dist-packages
.PHONY: distclean-packages genstubs checkstubs checkdoc checkuchar dist html
.PHONY: checkexports alldist allpatch html-tcl html-tk
#--------------------------------------------------------------------------
# DO NOT DELETE THIS LINE -- make depend depends on it.
|
Changes to unix/tclConfig.h.in.
| ︙ | ︙ | |||
375 376 377 378 379 380 381 | /* What type should be used to define wide integers? */ #undef TCL_WIDE_INT_TYPE /* Define to 1 if you can safely include both <sys/time.h> and <time.h>. */ #undef TIME_WITH_SYS_TIME | < < < | 375 376 377 378 379 380 381 382 383 384 385 386 387 388 | /* What type should be used to define wide integers? */ #undef TCL_WIDE_INT_TYPE /* Define to 1 if you can safely include both <sys/time.h> and <time.h>. */ #undef TIME_WITH_SYS_TIME /* Is getcwd Posix-compliant? */ #undef USEGETWD /* Do we need a special AIX hack for timezones? */ #undef USE_DELTA_FOR_TZ /* May we include <dirent2.h>? */ |
| ︙ | ︙ |
Changes to unix/tclooConfig.sh.
1 2 3 4 5 6 7 8 9 10 11 | # tclooConfig.sh -- # # This shell script (for sh) is generated automatically by TclOO's configure # script, or would be except it has no values that we substitute. It will # create shell variables for most of the configuration options discovered by # the configure script. This script is intended to be included by TEA-based # configure scripts for TclOO extensions so that they don't have to figure # this all out for themselves. # # The information in this file is specific to a single platform. # | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | # tclooConfig.sh -- # # This shell script (for sh) is generated automatically by TclOO's configure # script, or would be except it has no values that we substitute. It will # create shell variables for most of the configuration options discovered by # the configure script. This script is intended to be included by TEA-based # configure scripts for TclOO extensions so that they don't have to figure # this all out for themselves. # # The information in this file is specific to a single platform. # # RCS: @(#) $Id: tclooConfig.sh,v 1.1.2.3 2009/12/08 18:39:20 dgp Exp $ # These are mostly empty because no special steps are ever needed from Tcl 8.6 # onwards; all libraries and include files are just part of Tcl. TCLOO_LIB_SPEC="" TCLOO_STUB_LIB_SPEC="" TCLOO_INCLUDE_SPEC="" TCLOO_PRIVATE_INCLUDE_SPEC="" TCLOO_CFLAGS=-DUSE_TCLOO_STUBS TCLOO_VERSION=0.6.2 |
Changes to win/Makefile.in.
1 2 3 4 5 6 | # # This file is a Makefile for Tcl. If it has the name "Makefile.in" then it # is a template for a Makefile; to generate the actual Makefile, run # "./configure", which is a configuration script generated by the "autoconf" # program (constructs like "@foo@" will get replaced in the actual Makefile. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | # # This file is a Makefile for Tcl. If it has the name "Makefile.in" then it # is a template for a Makefile; to generate the actual Makefile, run # "./configure", which is a configuration script generated by the "autoconf" # program (constructs like "@foo@" will get replaced in the actual Makefile. # # RCS: @(#) $Id: Makefile.in,v 1.71.2.56 2009/12/08 18:39:20 dgp Exp $ VERSION = @TCL_VERSION@ #-------------------------------------------------------------------------- # Things you can change to personalize the Makefile for your own site (you can # make these changes in either Makefile.in or Makefile, but changes to # Makefile will get lost if you re-run the configuration script). |
| ︙ | ︙ | |||
406 407 408 409 410 411 412 | binaries: $(TCL_STUB_LIB_FILE) @LIBRARIES@ $(DDE_DLL_FILE) $(REG_DLL_FILE) $(TCLSH) libraries: doc: | | | | | 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 |
binaries: $(TCL_STUB_LIB_FILE) @LIBRARIES@ $(DDE_DLL_FILE) $(REG_DLL_FILE) $(TCLSH)
libraries:
doc:
$(TCLSH): $(TCLSH_OBJS) @LIBRARIES@ $(TCL_STUB_LIB_FILE) tclsh.$(RES)
$(CC) $(CFLAGS) $(TCLSH_OBJS) $(TCL_LIB_FILE) $(TCL_STUB_LIB_FILE) $(LIBS) \
tclsh.$(RES) $(CC_EXENAME) $(LDFLAGS_CONSOLE)
$(TCLTEST): testMain.$(OBJEXT) ${TEST_DLL_FILE} @LIBRARIES@ $(TCL_STUB_LIB_FILE) $(CAT32) tclsh.$(RES)
$(CC) $(CFLAGS) testMain.$(OBJEXT) ${TEST_LIB_FILE} $(TCL_LIB_FILE) $(TCL_STUB_LIB_FILE) $(LIBS) \
tclsh.$(RES) $(CC_EXENAME) $(LDFLAGS_CONSOLE)
cat32.$(OBJEXT): cat.c
$(CC) -c $(CC_SWITCHES) @DEPARG@ $(CC_OBJNAME)
$(CAT32): cat32.$(OBJEXT)
|
| ︙ | ︙ | |||
439 440 441 442 443 444 445 |
${TCL_LIB_FILE}: ${TCL_OBJS}
@$(RM) ${TCL_LIB_FILE}
@MAKE_LIB@ ${TCL_OBJS}
@POST_MAKE_LIB@
# assume GNU make
| > > > > | | | | | | | | | | | | | | | < < < < < < < < < | 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 |
${TCL_LIB_FILE}: ${TCL_OBJS}
@$(RM) ${TCL_LIB_FILE}
@MAKE_LIB@ ${TCL_OBJS}
@POST_MAKE_LIB@
# assume GNU make
# To enable concurrent parallel make of tcl<x>.dll and tcl<x>.lib, the tcl<x>.dll
# targets have to depend on tcl<x>.lib, this ensures that linking of tcl<x>.dll
# does not execute concurrently with the renaming and recompiling of tcl<x>.lib
${DDE_DLL_FILE}: ${DDE_OBJS} ${DDE_LIB_FILE} ${TCL_STUB_LIB_FILE}
@-$(RM) ${DDE_DLL_FILE} ${DDE_LIB_FILE}.sav
@-$(COPY) ${DDE_LIB_FILE} ${DDE_LIB_FILE}.sav
@MAKE_DLL@ ${DDE_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS)
@-$(RM) ${DDE_LIB_FILE}
@-$(COPY) ${DDE_LIB_FILE}.sav ${DDE_LIB_FILE}
@-$(RM) ${DDE_LIB_FILE}.sav
${DDE_LIB_FILE}: ${DDE_OBJS}
@$(RM) ${DDE_LIB_FILE}
@MAKE_LIB@ ${DDE_OBJS}
@POST_MAKE_LIB@
${REG_DLL_FILE}: ${REG_OBJS} ${REG_LIB_FILE} ${TCL_STUB_LIB_FILE}
@-$(RM) ${REG_DLL_FILE} ${REG_LIB_FILE}.sav
@-$(COPY) ${REG_LIB_FILE} ${REG_LIB_FILE}.sav
@MAKE_DLL@ ${REG_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS)
@-$(RM) ${REG_LIB_FILE}
@-$(COPY) ${REG_LIB_FILE}.sav ${REG_LIB_FILE}
@-$(RM) ${REG_LIB_FILE}.sav
${REG_LIB_FILE}: ${REG_OBJS}
@$(RM) ${REG_LIB_FILE}
@MAKE_LIB@ ${REG_OBJS}
@POST_MAKE_LIB@
${TEST_DLL_FILE}: ${TCLTEST_OBJS} ${TCL_STUB_LIB_FILE}
@$(RM) ${TEST_DLL_FILE} ${TEST_LIB_FILE}
@MAKE_DLL@ ${TCLTEST_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS)
# use pre-built zlib1.dll
${ZLIB_DLL_FILE}: $(ZLIB_DIR)/win32/${ZLIB_DLL_FILE}
@$(COPY) $(ZLIB_DIR)/win32/${ZLIB_DLL_FILE} ${ZLIB_DLL_FILE}
# PIPE_DLL_FILE is actually an executable, don't build it like a DLL.
|
| ︙ | ︙ | |||
717 718 719 720 721 722 723 | $(COPY) "$$i" "$(PRIVATE_INCLUDE_INSTALL_DIR)"; \ done; # Specifying TESTFLAGS on the command line is the standard way to pass args to # tcltest, i.e.: # % make test TESTFLAGS="-verbose bps -file fileName.test" | > > | | 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 |
$(COPY) "$$i" "$(PRIVATE_INCLUDE_INSTALL_DIR)"; \
done;
# Specifying TESTFLAGS on the command line is the standard way to pass args to
# tcltest, i.e.:
# % make test TESTFLAGS="-verbose bps -file fileName.test"
test: test-tcl test-packages
test-tcl: binaries $(TCLTEST)
TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \
./$(TCLTEST) "$(ROOT_DIR_NATIVE)/tests/all.tcl" $(TESTFLAGS) \
-load "set ::ddelib [file normalize ${DDE_DLL_FILE}]; \
set ::reglib [file normalize ${REG_DLL_FILE}]" | ./$(CAT32)
# Useful target to launch a built tcltest with the proper path,...
runtest: binaries $(TCLTEST)
|
| ︙ | ︙ | |||
872 873 874 875 876 877 878 | html: $(MAKE) shell SCRIPT="$(TOOL_DIR)/tcltk-man2html.tcl --htmldir=$(HTML_INSTALL_DIR) --srcdir=$(ROOT_DIR)/.. $(BUILD_HTML_FLAGS)" html-tcl: $(TCLSH) $(MAKE) shell SCRIPT="$(TOOL_DIR)/tcltk-man2html.tcl --htmldir=$(HTML_INSTALL_DIR) --srcdir=$(ROOT_DIR)/.. $(BUILD_HTML_FLAGS) --tcl" html-tk: $(TCLSH) $(MAKE) shell SCRIPT="$(TOOL_DIR)/tcltk-man2html.tcl --htmldir=$(HTML_INSTALL_DIR) --srcdir=$(ROOT_DIR)/.. $(BUILD_HTML_FLAGS) --tk" | > > > > > > > > > > > > > | 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 | html: $(MAKE) shell SCRIPT="$(TOOL_DIR)/tcltk-man2html.tcl --htmldir=$(HTML_INSTALL_DIR) --srcdir=$(ROOT_DIR)/.. $(BUILD_HTML_FLAGS)" html-tcl: $(TCLSH) $(MAKE) shell SCRIPT="$(TOOL_DIR)/tcltk-man2html.tcl --htmldir=$(HTML_INSTALL_DIR) --srcdir=$(ROOT_DIR)/.. $(BUILD_HTML_FLAGS) --tcl" html-tk: $(TCLSH) $(MAKE) shell SCRIPT="$(TOOL_DIR)/tcltk-man2html.tcl --htmldir=$(HTML_INSTALL_DIR) --srcdir=$(ROOT_DIR)/.. $(BUILD_HTML_FLAGS) --tk" # # The list of all the targets that do not correspond to real files. This stops # 'make' from getting confused when someone makes an error in a rule. # .PHONY: all tcltest binaries libraries doc gendate gentommath_h install .PHONY: install-binaries install-libraries install-tzdata install-msgs .PHONY: install-doc install-private-headers test test-tcl runtest shell .PHONY: gdb depend cleanhelp clean distclean packages install-packages .PHONY: test-packages clean-packages distclean-packages genstubs html .PHONY: html-tcl html-tk # DO NOT DELETE THIS LINE -- make depend depends on it. |
Changes to win/makefile.vc.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 | # Copyright (c) 1995-1996 Sun Microsystems, Inc. # Copyright (c) 1998-2000 Ajuba Solutions. # Copyright (c) 2001-2005 ActiveState Corporation. # Copyright (c) 2001-2004 David Gravereaux. # Copyright (c) 2003-2008 Pat Thoyts. # #------------------------------------------------------------------------------ | | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | # Copyright (c) 1995-1996 Sun Microsystems, Inc. # Copyright (c) 1998-2000 Ajuba Solutions. # Copyright (c) 2001-2005 ActiveState Corporation. # Copyright (c) 2001-2004 David Gravereaux. # Copyright (c) 2003-2008 Pat Thoyts. # #------------------------------------------------------------------------------ # RCS: @(#) $Id: makefile.vc,v 1.107.2.51 2009/12/08 18:39:20 dgp Exp $ #------------------------------------------------------------------------------ # Check to see we are configured to build with MSVC (MSDEVDIR or MSVCDIR) # or with the MS Platform SDK (MSSDK). Visual Studio .NET 2003 and 2005 define # VCINSTALLDIR instead. !if !defined(MSDEVDIR) && !defined(MSVCDIR) && !defined(MSSDK) && !defined(VCINSTALLDIR) MSG = ^ |
| ︙ | ︙ | |||
416 417 418 419 420 421 422 | $(TMP_DIR)\tclWinLoad.obj \ $(TMP_DIR)\tclWinNotify.obj \ $(TMP_DIR)\tclWinPipe.obj \ $(TMP_DIR)\tclWinSerial.obj \ $(TMP_DIR)\tclWinSock.obj \ $(TMP_DIR)\tclWinThrd.obj \ $(TMP_DIR)\tclWinTime.obj \ | | > > > | 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 | $(TMP_DIR)\tclWinLoad.obj \ $(TMP_DIR)\tclWinNotify.obj \ $(TMP_DIR)\tclWinPipe.obj \ $(TMP_DIR)\tclWinSerial.obj \ $(TMP_DIR)\tclWinSock.obj \ $(TMP_DIR)\tclWinThrd.obj \ $(TMP_DIR)\tclWinTime.obj \ !if $(STATIC_BUILD) $(TMP_DIR)\tclStubLib.obj $(TMP_DIR)\tclOOStubLib.obj !else $(TMP_DIR)\tcl.res !endif TCLOBJS = $(COREOBJS) $(ZLIBOBJS) $(TOMMATHOBJS) $(PLATFORMOBJS) TCLSTUBOBJS = \ |
| ︙ | ︙ | |||
616 617 618 619 620 621 622 | $(link32) $(conlflags) -out:$@ $(TMP_DIR)\stub16.obj $(baselibs) $(_VC_MANIFEST_EMBED_DLL) !if $(STATIC_BUILD) !if $(TCL_USE_STATIC_PACKAGES) $(TCLDDELIB): !else | | | | | | 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 | $(link32) $(conlflags) -out:$@ $(TMP_DIR)\stub16.obj $(baselibs) $(_VC_MANIFEST_EMBED_DLL) !if $(STATIC_BUILD) !if $(TCL_USE_STATIC_PACKAGES) $(TCLDDELIB): !else $(TCLDDELIB): $(TMP_DIR)\tclWinDde.obj $(TCLSTUBOBJS) $(lib32) -nologo $(LINKERFLAGS) -out:$@ $** !endif !else $(TCLDDELIB): $(TMP_DIR)\tclWinDde.obj $(TCLSTUBLIB) $(link32) $(dlllflags) -base:@$(WINDIR)\coffbase.txt,tcldde -out:$@ \ $** $(baselibs) $(_VC_MANIFEST_EMBED_DLL) !endif !if $(STATIC_BUILD) !if $(TCL_USE_STATIC_PACKAGES) $(TCLREGLIB): !else $(TCLREGLIB): $(TMP_DIR)\tclWinReg.obj $(TCLSTUBOBJS) $(lib32) -nologo $(LINKERFLAGS) -out:$@ $** !endif !else $(TCLREGLIB): $(TMP_DIR)\tclWinReg.obj $(TCLSTUBLIB) $(link32) $(dlllflags) -base:@$(WINDIR)\coffbase.txt,tclreg -out:$@ \ $** $(baselibs) $(_VC_MANIFEST_EMBED_DLL) !endif |
| ︙ | ︙ |
Changes to win/tclAppInit.c.
1 2 3 4 5 6 7 8 9 10 11 12 13 | /* * tclAppInit.c -- * * Provides a default version of the main program and Tcl_AppInit * function for Tcl applications (without Tk). Note that this program * must be built in Win32 console mode to work properly. * * Copyright (c) 1996-1997 by Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | /* * tclAppInit.c -- * * Provides a default version of the main program and Tcl_AppInit * function for Tcl applications (without Tk). Note that this program * must be built in Win32 console mode to work properly. * * Copyright (c) 1996-1997 by Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclAppInit.c,v 1.13.2.13 2009/12/08 18:39:20 dgp Exp $ */ #include "tcl.h" #include <windows.h> #include <locale.h> #ifdef TCL_TEST |
| ︙ | ︙ | |||
129 130 131 132 133 134 135 |
return TCL_ERROR;
}
#ifdef TCL_TEST
if (Tcltest_Init(interp) == TCL_ERROR) {
return TCL_ERROR;
}
| | | 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 |
return TCL_ERROR;
}
#ifdef TCL_TEST
if (Tcltest_Init(interp) == TCL_ERROR) {
return TCL_ERROR;
}
Tcl_StaticPackage(interp, "Tcltest", Tcltest_Init, NULL);
#endif /* TCL_TEST */
#if defined(STATIC_BUILD) && TCL_USE_STATIC_PACKAGES
{
extern Tcl_PackageInitProc Registry_Init;
extern Tcl_PackageInitProc Dde_Init;
extern Tcl_PackageInitProc Dde_SafeInit;
|
| ︙ | ︙ |
Changes to win/tclooConfig.sh.
1 2 3 4 5 6 7 8 9 10 11 | # tclooConfig.sh -- # # This shell script (for sh) is generated automatically by TclOO's configure # script, or would be except it has no values that we substitute. It will # create shell variables for most of the configuration options discovered by # the configure script. This script is intended to be included by TEA-based # configure scripts for TclOO extensions so that they don't have to figure # this all out for themselves. # # The information in this file is specific to a single platform. # | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | # tclooConfig.sh -- # # This shell script (for sh) is generated automatically by TclOO's configure # script, or would be except it has no values that we substitute. It will # create shell variables for most of the configuration options discovered by # the configure script. This script is intended to be included by TEA-based # configure scripts for TclOO extensions so that they don't have to figure # this all out for themselves. # # The information in this file is specific to a single platform. # # RCS: @(#) $Id: tclooConfig.sh,v 1.1.2.3 2009/12/08 18:39:20 dgp Exp $ # These are mostly empty because no special steps are ever needed from Tcl 8.6 # onwards; all libraries and include files are just part of Tcl. TCLOO_LIB_SPEC="" TCLOO_STUB_LIB_SPEC="" TCLOO_INCLUDE_SPEC="" TCLOO_PRIVATE_INCLUDE_SPEC="" TCLOO_CFLAGS=-DUSE_TCLOO_STUBS TCLOO_VERSION=0.6.2 |