diff options
| author | dkf <donal.k.fellows@manchester.ac.uk> | 2013-01-30 08:19:22 (GMT) |
|---|---|---|
| committer | dkf <donal.k.fellows@manchester.ac.uk> | 2013-01-30 08:19:22 (GMT) |
| commit | 52368789306fda3ae17cf554333fa3adb617ba0a (patch) | |
| tree | 10729608c91275933e64387693a867743563aab0 | |
| parent | bc3ea33b9b409c840682f5feb2b4efb4c78029f8 (diff) | |
| parent | 75972077579a3e9bf1363e817260d11f17d60266 (diff) | |
| download | tcl-novem_no_startcmd.zip tcl-novem_no_startcmd.tar.gz tcl-novem_no_startcmd.tar.bz2 | |
merge changes from trunknovem_no_startcmd
97 files changed, 2411 insertions, 1146 deletions
@@ -1,3 +1,242 @@ +2013-01-28 Donal K. Fellows <dkf@users.sf.net> + + * generic/tclCompCmds.c (TclCompileArraySetCmd) + (TclCompileArrayUnsetCmd, TclCompileDictAppendCmd) + (TclCompileDictCreateCmd, CompileDictEachCmd, TclCompileDictIncrCmd) + (TclCompileDictLappendCmd, TclCompileDictMergeCmd) + (TclCompileDictUnsetCmd, TclCompileDictUpdateCmd) + (TclCompileDictWithCmd, TclCompileInfoCommandsCmd): + * generic/tclCompCmdsSZ.c (TclCompileStringMatchCmd) + (TclCompileStringMapCmd): Improve the code generation in cases where + full compilation is impossible but a full ensemble invoke is provably + not necessary. + +2013-01-26 Jan Nijtmans <nijtmans@users.sf.net> + + * unix/tclUnixCompat.c: [Bug 3601804]: platformCPUID segmentation + fault on Darwin. + +2013-01-23 Donal K. Fellows <dkf@users.sf.net> + + * library/http/http.tcl (http::geturl): [Bug 2911139]: Do not do vwait + for connect to avoid reentrancy problems (except when operating + without a -command option). Internally, this means that all sockets + created by the http package will always be operated in asynchronous + mode. + +2013-01-21 Jan Nijtmans <nijtmans@users.sf.net> + + * generic/tclInt.decls: Put back Tcl[GS]etStartupScript(Path|FileName) + in private stub table, so extensions using this (like Tk 8.4) will + continue to work in all Tcl 8.x versions. Extensions using this + still cannot be compiled against Tcl 8.6 headers. + +2013-01-18 Jan Nijtmans <nijtmans@users.sf.net> + + * generic/tclPort.h: [Bug 3598300]: unix: tcl.h does not include + sys/stat.h + +2013-01-17 Donal K. Fellows <dkf@users.sf.net> + + * generic/tclCompCmds.c (PushVarName): [Bug 3600328]: Added mechanism + for suppressing compilation of variables when we couldn't cope with + the results. Useful for some [array] subcommands. + * generic/tclEnsemble.c (CompileToCompiledCommand): Must restore the + compilation environment when a command compiler fails. + +2013-01-16 Donal K. Fellows <dkf@users.sf.net> + + * generic/tclZlib.c (TclZlibInit): [Bug 3601086]: Register the config + info in the iso8859-1 encoding as that is guaranteed to be present. + +2013-01-16 Jan Nijtmans <nijtmans@users.sf.net> + + * Makefile.in: Allow win32 build with -DTCL_NO_DEPRECATED, just as + * generic/tcl.h: in the UNIX build. Define Tcl_EvalObj and + * generic/tclDecls.h: Tcl_GlobalEvalObj as macros, even when + * generic/tclBasic.c: TCL_NO_DEPRECATED is defined, so Tk can benefit + from it too. + +2013-01-14 Jan Nijtmans <nijtmans@users.sf.net> + + * win/tcl.m4: More flexible search for win32 tclConfig.sh, backported + from TEA (not actually used in Tcl, only for Tk) + +2013-01-14 Jan Nijtmans <nijtmans@users.sf.net> + + * generic/tclInt.decls: Put back Tcl_[GS]etStartupScript in internal + stub table, so extensions using this, compiled against 8.5 headers + still run in Tcl 8.6. + +2013-01-13 Alexandre Ferrieux <ferrieux@users.sourceforge.net> + + * doc/fileevent.n: [Bug 3436609]: Clarify readable fileevent "false + positives" in the case of multibyte encodings/transforms. + +2013-01-13 Jan Nijtmans <nijtmans@users.sf.net> + + * generic/tclIntDecls.h: If TCL_NO_DEPRECATED is defined, make sure + that TIP #139 functions all are taken from the public stub table, even + if the inclusion is through tclInt.h. + +2013-01-12 Jan Nijtmans <nijtmans@users.sf.net> + + * generic/tclInt.decls: Put back TclBackgroundException in internal + stub table, so extensions using this, compiled against 8.5 headers + still run in Tcl 8.6. + +2013-01-09 Jan Nijtmans <nijtmans@users.sf.net> + + * library/http/http.tcl: [Bug 3599395]: http assumes status line is a + proper Tcl list. + +2013-01-08 Jan Nijtmans <nijtmans@users.sf.net> + + * win/tclWinFile.c: [Bug 3092089]: [file normalize] can remove path + components. [Bug 3587096] win vista/7: "can't find init.tcl" when + called via junction without folder list access. + +2013-01-07 Jan Nijtmans <nijtmans@users.sf.net> + + * generic/tclOOStubLib.c: Restrict the stub library to only use + * generic/tclTomMathStubLib.c: Tcl_PkgRequireEx, Tcl_ResetResult and + Tcl_AppendResult, not any other function. This puts least restrictions + on eventual Tcl 9 stubs re-organization, and it works on the widest + range of Tcl versions. + +2013-01-06 Jan Nijtmans <nijtmans@users.sf.net> + + * library/http/http.tcl: Don't depend on Spencer-specific regexp + * tests/env.test: syntax (/u and /U) any more in unrelated places. + * tests/exec.test: + Bump http package to 2.8.6. + +2013-01-04 Donal K. Fellows <dkf@users.sf.net> + + * generic/tclEnsemble.c (CompileBasicNArgCommand): Added very simple + compiler (which just compiles to a normal invoke of the implementation + command) for many ensemble subcommands where we can prove that there + is no way for scripts to detect the difference even through error + handling or [info level]/[info frame]. This improves the code produced + from some ensembles (e.g., [info], [string]) to the point where the + ensemble is now not normally seen at the bytecode level at all. + +2013-01-04 Miguel Sofer <msofer@users.sf.net> + + * generic/tclInt.h: Insure that PURIFY builds cannot exploit the + * generic/tclExecute.c: Tcl stack to hide mem defects. + +2013-01-03 Donal K. Fellows <dkf@users.sf.net> + + * doc/fconfigure.n, doc/CrtChannel.3: Updated to reflect the fact that + the minimum buffer size is one byte, not ten. Identified by Schelte + Bron on the Tcler's Chat. + + * generic/tclExecute.c (TEBCresume:INST_INVOKE_REPLACE): + * generic/tclEnsemble.c (TclCompileEnsemble): Added new mechanism to + allow for more efficient dispatch of non-bytecode-compiled subcommands + of bytecode-compiled ensembles. This can provide substantial speed + benefits in some cases. + +2013-01-02 Miguel Sofer <msofer@users.sf.net> + + * generic/tclEnsemble.c: Remove stray calls to Tcl_Alloc and friends: + * generic/tclExecute.c: the core should only use ckalloc to allow + * generic/tclIORTrans.c: MEM_DEBUG to work properly. + * generic/tclTomMathInterface.c: + +2012-12-31 Donal K. Fellows <dkf@users.sf.net> + + * doc/string.n: Noted the obsolescence of the 'bytelength', + 'wordstart' and 'wordend' subcommands, and moved them to later in the + file. + +2012-12-27 Jan Nijtmans <nijtmans@users.sf.net> + + * generic/tclListObj.c: [Bug 3598580]: Tcl_ListObjReplace may release + deleted elements too early. + +2012-12-22 Alexandre Ferrieux <ferrieux@users.sourceforge.net> + + * generic/tclUtil.c: Stop leaking allocated space when objifying a + zero-length DString. [Bug 3598150] spotted by afredd. + +2012-12-21 Jan Nijtmans <nijtmans@users.sf.net> + + * unix/dltest/pkgb.c: Inline compat Tcl_GetDefaultEncodingDir. + * generic/tclStubLib.c: Eliminate unnecessary static HasStubSupport() + and isDigit() functions, just do the same inline. + +2012-12-18 Donal K. Fellows <dkf@users.sf.net> + + * generic/tclCompCmdsSZ.c (TclSubstCompile): Improved the sequence of + instructions issued for [subst] when dealing with simple variable + references. + +2012-12-14 Don Porter <dgp@users.sourceforge.net> + + *** 8.6.0 TAGGED FOR RELEASE *** + + * changes: updates for 8.6.0 + +2012-12-13 Don Porter <dgp@users.sourceforge.net> + + * generic/tclZlib.c: Repair same issue with misusing the + * tests/zlib.test: 'fire and forget' nature of Tcl_ObjSetVar2 + in the new TIP 400 implementation. + +2012-12-13 Miguel Sofer <msofer@users.sf.net> + + * generic/tclCmdAH.c: (CatchObjCmdCallback): do not decrRefCount + * tests/cmdAH.test: the newValuePtr sent to Tcl_ObjSetVar2: + TOSV2 is 'fire and forget', it decrs on its own. + Fix for [Bug 3595576], found by andrewsh. + +2012-12-13 Jan Nijtmans <nijtmans@users.sf.net> + + * generic/tcl.h: Fix Tcl_DecrRefCount macro such that it doesn't + access its objPtr parameter twice any more. + +2012-12-11 Don Porter <dgp@users.sourceforge.net> + + * generic/tcl.h: Bump version number to 8.6.0. + * library/init.tcl: + * unix/configure.in: + * win/configure.in: + * unix/tcl.spec: + * README: + + * unix/configure: autoconf-2.59 + * win/configure: + +2012-12-10 Donal K. Fellows <dkf@users.sf.net> + + * tools/tcltk-man2html.tcl (plus-pkgs): Increased robustness of + version number detection code to deal with packages whose names are + prefixes of other packages. + * unix/Makefile.in (dist): Added pkgs/package.list.txt to distribution + builds to ensure that 'make html' will work better. + +2012-12-09 Alexandre Ferrieux <ferrieux@users.sourceforge.net> + + * tests/chan.test: Clean up unwanted eofchar side-effect of chan-4.6 + leading to a spurious "'" at end of chan.test under certain conditions + (see [Bug 3389289] and [Bug 3389251]). + + * doc/expr.n: [Bug 3594188]: Clarifications about commas. + +2012-12-08 Alexandre Ferrieux <ferrieux@users.sourceforge.net> + + * generic/tclIO.c: Fix busyloop at exit under TCL_FINALIZE_ON_EXIT + when there are unflushed nonblocking channels. Thanks Miguel for + spotting. + +2012-12-07 Jan Nijtmans <nijtmans@users.sf.net> + + * unix/dltest/pkgb.c: Turn pkgb.so into a Tcl9 interoperability test + library: Whatever Tcl9 looks like, loading pkgb.so in Tcl 9 should + either result in an error-message, either succeed, but never crash. + 2012-11-28 Donal K. Fellows <dkf@users.sf.net> * generic/tclZlib.c (ZlibStreamSubcmd): [Bug 3590483]: Use a mechanism @@ -7,10 +246,10 @@ 2012-11-26 Reinhard Max <max@suse.de> * unix/tclUnixSock.c: Factor out creation of the -sockname and - -peername lists from TcpGetOptionProc() to TcpHostPortList(). - Make it robust against implementations of getnameinfo() that error - out if reverse mapping fails instead of falling back to the - numeric representation. + -peername lists from TcpGetOptionProc() to TcpHostPortList(). Make it + robust against implementations of getnameinfo() that error out if + reverse mapping fails instead of falling back to the numeric + representation. 2012-11-20 Donal K. Fellows <dkf@users.sf.net> @@ -3960,6 +4199,7 @@ * generic/*Decls.h: (regenerated) 2010-08-18 Miguel Sofer <msofer@users.sf.net> + * generic/tclBasic.c: New redesign of [tailcall]: find * generic/tclExecute.c: errors early on, so that errorInfo * generic/tclInt.h: contains the proper info [Bug 3047235] @@ -8117,11 +8117,49 @@ Dropped support for OS X versions less than 10.4 (Tiger) (fellows) --- Released 8.6b3, September 18, 2012 --- See ChangeLog for details --- +2012-09-20 (enhancement) full Unicode support (nijtmans) +=> dde 1.4.0 + +2012-09-20 (enhancement) update bundled zlib to 1.2.7 (nijtmans) + 2012-10-03 (bug fix) exit panic on stacked std channel (griffin,porter) 2012-10-14 (bug fix) [tcl::Bgerror] crash on non-dict options (nijtmans) +2012-10-16 (TIP 400) New [zlib] options to set compression dict (fellows) + +2012-10-16 (TIP 405) New commands [lmap] and [dict map] (fellows) + +2012-10-24 (enhancement) [dict unset] now bytecompiled (fellows) + +2012-11-05 (TIP 413) Revisions to default [string trim*] trimset (nijtmans) + *** POTENTIAL INCOMPATIBILITY *** + +2012-11-05 (enhancement) Now bytecompiled: [array exists], [array set], +[array unset], [dict create], [dict exists], [dict merge], [format], +[info commands], [info coroutine], [info level], [info object], +[namespace current], [namespace code], [namespace qualifiers], [namespace tail], +[namespace which], [regsub], [self], [string first], [string last], +[string map], [string range], [tailcall], [yield]. (fellows) + 2012-11-06 (bug fix)[3581754] avoid multiple callback on keep-alive (fellows) => http 2.8.5 ---- Released 8.6.0, ??? ??, 2012 --- See ChangeLog for details --- +2012-11-07 tzdata updated to Olson's tzdata2012i (kenny) + +2012-11-13 (bug fix)[3567063] thread fp settings from master (mistachkin) + +2012-11-14 (bug fix)[2933003] tempfile creation in $TMPDIR (fellows) + +2012-11-15 (TIP 416) New [load] options -global and -lazy (nijtmans) + +2012-11-20 (bug fix)[3033307] base64 trail whitespace (kovalenko,goth) + +2012-12-03 (bug fix) [configure] query broke init from argv (porter) +=> tcltest 2.3.5 + +2012-12-13 (bug fix)[3595576] crash: [catch {} -> noSuchNs::var] (sofer,porter) + +2012-12-13 (bug fix) crash: [zlib gunzip $data -header noSuchNs::var] (porter) + +--- Released 8.6.0, December 20, 2012 --- See ChangeLog for details --- diff --git a/compat/dirent2.h b/compat/dirent2.h index 878457f..5be08ba 100644 --- a/compat/dirent2.h +++ b/compat/dirent2.h @@ -14,8 +14,6 @@ #ifndef _DIRENT #define _DIRENT -#include "tcl.h" - /* * Dirent structure, which holds information about a single * directory entry. diff --git a/compat/dlfcn.h b/compat/dlfcn.h index 6940c2a..fb27ea0 100644 --- a/compat/dlfcn.h +++ b/compat/dlfcn.h @@ -26,8 +26,6 @@ #ifndef __dlfcn_h__ #define __dlfcn_h__ -#include "tcl.h" - #ifdef __cplusplus extern "C" { #endif diff --git a/compat/string.h b/compat/string.h index 84ee094..42be10c 100644 --- a/compat/string.h +++ b/compat/string.h @@ -13,8 +13,6 @@ #ifndef _STRING #define _STRING -#include "tcl.h" - /* * The following #include is needed to define size_t. (This used to include * sys/stdtypes.h but that doesn't exist on older versions of SunOS, e.g. diff --git a/compat/unistd.h b/compat/unistd.h index 6779e74..2de5bd0 100644 --- a/compat/unistd.h +++ b/compat/unistd.h @@ -14,7 +14,6 @@ #ifndef _UNISTD #define _UNISTD -#include "tcl.h" #include <sys/types.h> #ifndef NULL diff --git a/doc/CrtChannel.3 b/doc/CrtChannel.3 index 55a4024..57bb76e 100644 --- a/doc/CrtChannel.3 +++ b/doc/CrtChannel.3 @@ -250,8 +250,8 @@ the default value of 4096 is returned. .PP \fBTcl_SetChannelBufferSize\fR sets the size, in bytes, of buffers that will be allocated in subsequent operations on the channel to store input or -output. The \fIsize\fR argument should be between ten and one million, -allowing buffers of ten bytes to one million bytes. If \fIsize\fR is +output. The \fIsize\fR argument should be between one and one million, +allowing buffers of one byte to one million bytes. If \fIsize\fR is outside this range, \fBTcl_SetChannelBufferSize\fR sets the buffer size to 4096. .PP diff --git a/doc/InitStubs.3 b/doc/InitStubs.3 index 5f56278..4dc62c6 100644 --- a/doc/InitStubs.3 +++ b/doc/InitStubs.3 @@ -63,9 +63,9 @@ Define the \fBUSE_TCL_STUBS\fR symbol. Typically, you would include the \fB\-DUSE_TCL_STUBS\fR flag when compiling the extension. .IP 3) 5 Link the extension with the Tcl stubs library instead of the standard -Tcl library. For example, to use the Tcl 8.1 ABI on Unix platforms, -the library name is \fIlibtclstub8.1.a\fR; on Windows platforms, the -library name is \fItclstub81.lib\fR. +Tcl library. For example, to use the Tcl 8.6 ABI on Unix platforms, +the library name is \fIlibtclstub8.6.a\fR; on Windows platforms, the +library name is \fItclstub86.lib\fR. .PP If the extension also requires the Tk API, it must also call \fBTk_InitStubs\fR to initialize the Tk stubs interface and link @@ -295,7 +295,7 @@ int int result) { /* \fIdata[0] .. data[3]\fR are the four words of data - * passed to \fBTcl_NREvalObj\fR */ + * passed to \fBTcl_NRAddCallback\fR */ \fI... postprocessing ...\fR @@ -39,9 +39,9 @@ additional operators not found in C. .SS OPERANDS .PP A Tcl expression consists of a combination of operands, operators, -and parentheses. +parentheses and commas. White space may be used between the operands and operators and -parentheses; it is ignored by the expression's instructions. +parentheses (or commas); it is ignored by the expression's instructions. Where possible, operands are interpreted as integer values. Integer values may be specified in decimal (the normal case), in binary (if the first two characters of the operand are \fB0b\fR), in octal @@ -280,6 +280,18 @@ rules for resolving functions in namespaces. Either current]::tcl::mathfunc::sin\fR will satisfy the request, and others may as well (depending on the current \fBnamespace path\fR setting). .PP +Some mathematical functions have several arguments, separated by commas like in C. Thus: +.PP +.CS +\fBexpr\fR {hypot($x,$y)} +.CE +.PP +ends up as +.PP +.CS +tcl::mathfunc::hypot $x $y +.CE +.PP See the \fBmathfunc\fR(n) manual page for the math functions that are available by default. .SS "TYPES, OVERFLOW, AND PRECISION" diff --git a/doc/fconfigure.n b/doc/fconfigure.n index ac0366c..550d071 100644 --- a/doc/fconfigure.n +++ b/doc/fconfigure.n @@ -72,8 +72,8 @@ initially set to \fBline\fR, and \fBstderr\fR is set to \fBnone\fR. . \fINewvalue\fR must be an integer; its value is used to set the size of buffers, in bytes, subsequently allocated for this channel to store input -or output. \fINewvalue\fR must be between ten and one million, allowing -buffers of ten to one million bytes in size. +or output. \fINewvalue\fR must be between one and one million, allowing +buffers of one to one million bytes in size. .TP \fB\-encoding\fR \fIname\fR . diff --git a/doc/fileevent.n b/doc/fileevent.n index df48d2a..e453748 100644 --- a/doc/fileevent.n +++ b/doc/fileevent.n @@ -80,13 +80,16 @@ A channel is considered to be writable if at least one byte of data can be written to the underlying file or device without blocking, or if an error condition is present on the underlying file or device. .PP -Event-driven I/O works best for channels that have been -placed into nonblocking mode with the \fBfconfigure\fR command. -In blocking mode, a \fBputs\fR command may block if you give it -more data than the underlying file or device can accept, and a -\fBgets\fR or \fBread\fR command will block if you attempt to read -more data than is ready; no events will be processed while the -commands block. +Event-driven I/O works best for channels that have been placed into +nonblocking mode with the \fBfconfigure\fR command. In blocking mode, +a \fBputs\fR command may block if you give it more data than the +underlying file or device can accept, and a \fBgets\fR or \fBread\fR +command will block if you attempt to read more data than is ready; a +readable underlying file or device may not even guarantee that a +blocking [read 1] will succeed (counter-examples being multi-byte +encodings, compression or encryption transforms ). In all such cases, +no events will be processed while the commands block. +.PP In nonblocking mode \fBputs\fR, \fBread\fR, and \fBgets\fR never block. See the documentation for the individual commands for information on how they handle blocking and nonblocking channels. diff --git a/doc/namespace.n b/doc/namespace.n index b06d27a..f2812b2 100644 --- a/doc/namespace.n +++ b/doc/namespace.n @@ -287,7 +287,7 @@ This command is the complement of the \fBnamespace qualifiers\fR command. It does not check whether the namespace names are, in fact, the names of currently defined namespaces. .TP -\fBnamespace upvar\fR \fInamespace\fR ?\fIotherVar myVar \fR... +\fBnamespace upvar\fR \fInamespace\fR ?\fIotherVar myVar \fR...? . This command arranges for zero or more local variables in the current procedure to refer to variables in \fInamespace\fR. The namespace name is diff --git a/doc/string.n b/doc/string.n index 6b3cc59..351c865 100644 --- a/doc/string.n +++ b/doc/string.n @@ -19,27 +19,7 @@ string \- Manipulate strings Performs one of several string operations, depending on \fIoption\fR. The legal \fIoption\fRs (which may be abbreviated) are: .TP -\fBstring bytelength \fIstring\fR -. -Returns a decimal string giving the number of bytes used to represent -\fIstring\fR in memory. Because UTF\-8 uses one to three bytes to -represent Unicode characters, the byte length will not be the same as -the character length in general. The cases where a script cares about -the byte length are rare. -.RS -.PP -In almost all cases, you should use the -\fBstring length\fR operation (including determining the length of a -Tcl byte array value). Refer to the \fBTcl_NumUtfChars\fR manual -entry for more details on the UTF\-8 representation. -.PP -\fICompatibility note:\fR it is likely that this subcommand will be -withdrawn in a future version of Tcl. It is better to use the -\fBencoding convertto\fR command to convert a string to a known -encoding and then apply \fBstring length\fR to that. -.RE -.TP -\fBstring compare\fR ?\fB\-nocase\fR? ?\fB\-length int\fR? \fIstring1 string2\fR +\fBstring compare\fR ?\fB\-nocase\fR? ?\fB\-length\fI length\fR? \fIstring1 string2\fR . Perform a character-by-character comparison of strings \fIstring1\fR and \fIstring2\fR. Returns \-1, 0, or 1, depending on whether @@ -49,7 +29,7 @@ first \fIlength\fR characters are used in the comparison. If \fB\-length\fR is negative, it is ignored. If \fB\-nocase\fR is specified, then the strings are compared in a case-insensitive manner. .TP -\fBstring equal\fR ?\fB\-nocase\fR? ?\fB\-length int\fR? \fIstring1 string2\fR +\fBstring equal\fR ?\fB\-nocase\fR? ?\fB\-length\fI length\fR? \fIstring1 string2\fR . Perform a character-by-character comparison of strings \fIstring1\fR and \fIstring2\fR. Returns 1 if \fIstring1\fR and \fIstring2\fR are @@ -354,6 +334,31 @@ Returns a value equal to \fIstring\fR except that any trailing characters present in the string given by \fIchars\fR are removed. If \fIchars\fR is not specified then white space is removed (any character for which \fBstring is space\fR returns 1, and "\0"). +.SS "OBSOLETE SUBCOMMANDS" +.PP +These subcommands are currently supported, but are likely to go away in a +future release as their functionality is either virtually never used or highly +misleading. +.TP +\fBstring bytelength \fIstring\fR +. +Returns a decimal string giving the number of bytes used to represent +\fIstring\fR in memory. Because UTF\-8 uses one to three bytes to +represent Unicode characters, the byte length will not be the same as +the character length in general. The cases where a script cares about +the byte length are rare. +.RS +.PP +In almost all cases, you should use the +\fBstring length\fR operation (including determining the length of a +Tcl byte array value). Refer to the \fBTcl_NumUtfChars\fR manual +entry for more details on the UTF\-8 representation. +.PP +\fICompatibility note:\fR it is likely that this subcommand will be +withdrawn in a future version of Tcl. It is better to use the +\fBencoding convertto\fR command to convert a string to a known +encoding and then apply \fBstring length\fR to that. +.RE .TP \fBstring wordend \fIstring charIndex\fR . diff --git a/generic/tcl.h b/generic/tcl.h index 162983b..924f5d8 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -349,7 +349,7 @@ typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt; struct {long tv_sec;} st_ctim; /* Here is a 4-byte gap */ } Tcl_StatBuf; -#elif defined(HAVE_STRUCT_STAT64) +#elif defined(HAVE_STRUCT_STAT64) && !defined(__APPLE__) typedef struct stat64 Tcl_StatBuf; #else typedef struct stat Tcl_StatBuf; @@ -681,10 +681,7 @@ typedef struct Tcl_Obj { * whether an object is shared (i.e. has reference count > 1). Note: clients * should use Tcl_DecrRefCount() when they are finished using an object, and * should never call TclFreeObj() directly. TclFreeObj() is only defined and - * made public in tcl.h to support Tcl_DecrRefCount's macro definition. Note - * also that Tcl_DecrRefCount() refers to the parameter "obj" twice. This - * means that you should avoid calling it with an expression that is expensive - * to compute or has side effects. + * made public in tcl.h to support Tcl_DecrRefCount's macro definition. */ void Tcl_IncrRefCount(Tcl_Obj *objPtr); @@ -2310,7 +2307,12 @@ TCLAPI void Tcl_GetMemoryInfo(Tcl_DString *dsPtr); * http://c2.com/cgi/wiki?TrivialDoWhileLoop */ # define Tcl_DecrRefCount(objPtr) \ - do { if (--(objPtr)->refCount <= 0) TclFreeObj(objPtr); } while(0) + do { \ + Tcl_Obj *_objPtr = (objPtr); \ + if (--(_objPtr)->refCount <= 0) { \ + TclFreeObj(_objPtr); \ + } \ + } while(0) # define Tcl_IsShared(objPtr) \ ((objPtr)->refCount > 1) #endif @@ -2409,6 +2411,9 @@ TCLAPI void Tcl_GetMemoryInfo(Tcl_DString *dsPtr); # undef Tcl_EvalObj # define Tcl_EvalObj(interp,objPtr) \ Tcl_EvalObjEx((interp),(objPtr),0) +# undef Tcl_GlobalEvalObj +# define Tcl_GlobalEvalObj(interp,objPtr) \ + Tcl_EvalObjEx((interp),(objPtr),TCL_EVAL_GLOBAL) #endif /* !TCL_NO_DEPRECATED */ diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index dbc5e36..300e3fd 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -703,12 +703,10 @@ TclNRAssembleObjCmd( if (codePtr == NULL) { Tcl_AddErrorInfo(interp, "\n (\""); - Tcl_AddErrorInfo(interp, Tcl_GetString(objv[0])); + Tcl_AppendObjToErrorInfo(interp, objv[0]); Tcl_AddErrorInfo(interp, "\" body, line "); backtrace = Tcl_NewIntObj(Tcl_GetErrorLine(interp)); - Tcl_IncrRefCount(backtrace); - Tcl_AddErrorInfo(interp, Tcl_GetString(backtrace)); - Tcl_DecrRefCount(backtrace); + Tcl_AppendObjToErrorInfo(interp, backtrace); Tcl_AddErrorInfo(interp, ")"); return TCL_ERROR; } @@ -4114,11 +4112,11 @@ AddBasicBlockRangeToErrorInfo( Tcl_AddErrorInfo(interp, "\n in assembly code between lines "); lineNo = Tcl_NewIntObj(bbPtr->startLine); Tcl_IncrRefCount(lineNo); - Tcl_AddErrorInfo(interp, Tcl_GetString(lineNo)); + Tcl_AppendObjToErrorInfo(interp, lineNo); Tcl_AddErrorInfo(interp, " and "); if (bbPtr->successor1 != NULL) { Tcl_SetIntObj(lineNo, bbPtr->successor1->startLine); - Tcl_AddErrorInfo(interp, Tcl_GetString(lineNo)); + Tcl_AppendObjToErrorInfo(interp, lineNo); } else { Tcl_AddErrorInfo(interp, "end of assembly code"); } diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 7202184..ab712e8 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -123,7 +123,6 @@ static Tcl_NRPostProc NRCoroutineCallerCallback; static Tcl_NRPostProc NRCoroutineExitCallback; static int NRCommand(ClientData data[], Tcl_Interp *interp, int result); -static Tcl_NRPostProc NRRunObjProc; static void ProcessUnexpectedResult(Tcl_Interp *interp, int returnCode); static int RewindCoroutine(CoroutineData *corPtr, int result); @@ -146,10 +145,7 @@ static Tcl_NRPostProc TEOV_Exception; static Tcl_NRPostProc TEOV_NotFoundCallback; static Tcl_NRPostProc TEOV_RestoreVarFrame; static Tcl_NRPostProc TEOV_RunLeaveTraces; -static Tcl_NRPostProc YieldToCallback; -static void ClearTailcall(Tcl_Interp *interp, - struct NRE_callback *tailcallPtr); static Tcl_ObjCmdProc NRCoroInjectObjCmd; MODULE_SCOPE const TclStubs tclStubs; @@ -3770,7 +3766,8 @@ TclNREvalObjv( int result; Namespace *lookupNsPtr = iPtr->lookupNsPtr; Command **cmdPtrPtr; - + NRE_callback *callbackPtr; + iPtr->lookupNsPtr = NULL; /* @@ -3783,15 +3780,14 @@ TclNREvalObjv( * finishes the source command and not just the target. */ - if (iPtr->evalFlags & TCL_EVAL_REDIRECT) { - TclNRAddCallback(interp, NRCommand, NULL, INT2PTR(1), INT2PTR(objc), objv); - iPtr->evalFlags &= ~TCL_EVAL_REDIRECT; + if (iPtr->deferredCallbacks) { + callbackPtr = iPtr->deferredCallbacks; + iPtr->deferredCallbacks = NULL; } else { - TclNRAddCallback(interp, NRCommand, NULL, NULL, INT2PTR(objc), objv); + TclNRAddCallback(interp, NRCommand, NULL, NULL, NULL, NULL); + callbackPtr = TOP_CB(interp); } - cmdPtrPtr = (Command **) &(TOP_CB(interp)->data[0]); - - TclNRSpliceDeferred(interp); + cmdPtrPtr = (Command **) &(callbackPtr->data[0]); iPtr->numLevels++; result = TclInterpReady(interp); @@ -3905,27 +3901,16 @@ TclNREvalObjv( cmdPtr->refCount++; /* - * Find the objProc to call: nreProc if available, objProc otherwise. Push - * a callback to do the actual running. + * Find the objProc to call: nreProc if available, objProc otherwise. */ if (cmdPtr->nreProc) { - TclNRAddCallback(interp, NRRunObjProc, cmdPtr, - INT2PTR(objc), (ClientData) objv, NULL); - return TCL_OK; + return cmdPtr->nreProc(cmdPtr->objClientData, interp, objc, objv); } else { return cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv); } } -void -TclPushTailcallPoint( - Tcl_Interp *interp) -{ - TclNRAddCallback(interp, NRCommand, NULL, NULL, NULL, NULL); - ((Interp *) interp)->numLevels++; -} - int TclNRRunCallbacks( Tcl_Interp *interp, @@ -3962,6 +3947,14 @@ NRCommand( } ((Interp *)interp)->numLevels--; + /* + * If there is a tailcall, schedule it + */ + + if (data[1] && (data[1] != INT2PTR(1))) { + TclNRAddCallback(interp, TclNRTailcallEval, data[1], NULL, NULL, NULL); + } + /* OPT ?? * Do not interrupt a series of cleanups with async or limit checks: * just check at the end? @@ -3979,22 +3972,6 @@ NRCommand( return result; } - -static int -NRRunObjProc( - ClientData data[], - Tcl_Interp *interp, - int result) -{ - /* OPT: do not call? */ - - Command* cmdPtr = data[0]; - int objc = PTR2INT(data[1]); - Tcl_Obj **objv = data[2]; - - return cmdPtr->nreProc(cmdPtr->objClientData, interp, objc, objv); -} - /* *---------------------------------------------------------------------- @@ -4219,9 +4196,9 @@ TEOV_NotFound( savedNsPtr = varFramePtr->nsPtr; varFramePtr->nsPtr = lookupNsPtr; } - TclNRDeferCallback(interp, TEOV_NotFoundCallback, INT2PTR(handlerObjc), + TclSkipTailcall(interp); + TclNRAddCallback(interp, TEOV_NotFoundCallback, INT2PTR(handlerObjc), newObjv, savedNsPtr, NULL); - iPtr->evalFlags |= TCL_EVAL_REDIRECT; return TclNREvalObjv(interp, newObjc, newObjv, TCL_EVAL_NOERR, NULL); } @@ -5372,7 +5349,7 @@ Tcl_Eval( /* *---------------------------------------------------------------------- * - * Tcl_EvalObj -- + * Tcl_EvalObj, Tcl_GlobalEvalObj -- * * These functions are deprecated but we keep them around for backwards * compatibility reasons. @@ -5394,6 +5371,14 @@ Tcl_EvalObj( { return Tcl_EvalObjEx(interp, objPtr, 0); } +#undef Tcl_GlobalEvalObj +int +Tcl_GlobalEvalObj( + Tcl_Interp *interp, + Tcl_Obj *objPtr) +{ + return Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL); +} /* *---------------------------------------------------------------------- @@ -5541,7 +5526,8 @@ TclNREvalObjEx( iPtr->cmdFramePtr = eoFramePtr; } - TclNRDeferCallback(interp, TEOEx_ListCallback, listPtr, eoFramePtr, + TclMarkTailcall(interp); + TclNRAddCallback(interp, TEOEx_ListCallback, listPtr, eoFramePtr, NULL, NULL); ListObjGetElements(listPtr, objc, objv); @@ -7730,29 +7716,58 @@ Tcl_NRCmdSwap( */ void -TclSpliceTailcall( +TclMarkTailcall( + Tcl_Interp *interp) +{ + Interp *iPtr = (Interp *) interp; + + if (iPtr->deferredCallbacks == NULL) { + TclNRAddCallback(interp, NRCommand, NULL, NULL, + NULL, NULL); + iPtr->deferredCallbacks = TOP_CB(interp); + } +} + +void +TclSkipTailcall( + Tcl_Interp *interp) +{ + Interp *iPtr = (Interp *) interp; + + TclMarkTailcall(interp); + iPtr->deferredCallbacks->data[1] = INT2PTR(1); +} + +void +TclPushTailcallPoint( + Tcl_Interp *interp) +{ + TclNRAddCallback(interp, NRCommand, NULL, NULL, NULL, NULL); + ((Interp *) interp)->numLevels++; +} + +void +TclSetTailcall( Tcl_Interp *interp, - NRE_callback *tailcallPtr) + Tcl_Obj *listPtr) { /* * Find the splicing spot: right before the NRCommand of the thing - * being tailcalled. Note that we skip NRCommands marked in data[1] + * being tailcalled. Note that we skip NRCommands marked by a 1 in data[1] * (used by command redirectors). */ NRE_callback *runPtr; for (runPtr = TOP_CB(interp); runPtr; runPtr = runPtr->nextPtr) { - if (((runPtr->procPtr) == NRCommand) && !runPtr->data[1]) { + if (((runPtr->procPtr) == NRCommand) && !runPtr->data[1]) { break; } } if (!runPtr) { Tcl_Panic("tailcall cannot find the right splicing spot: should not happen!"); } - - tailcallPtr->nextPtr = runPtr->nextPtr; - runPtr->nextPtr = tailcallPtr; + runPtr->data[1] = listPtr; } int @@ -7782,7 +7797,7 @@ TclNRTailcallObjCmd( */ if (iPtr->varFramePtr->tailcallPtr) { - ClearTailcall(interp, iPtr->varFramePtr->tailcallPtr); + Tcl_DecrRefCount(iPtr->varFramePtr->tailcallPtr); iPtr->varFramePtr->tailcallPtr = NULL; } @@ -7797,23 +7812,20 @@ TclNRTailcallObjCmd( Tcl_Obj *listPtr, *nsObjPtr; Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr; Tcl_Namespace *ns1Ptr; - NRE_callback *tailcallPtr; - listPtr = Tcl_NewListObj(objc-1, objv+1); - Tcl_IncrRefCount(listPtr); + /* The tailcall data is in a Tcl list: the first element is the + * namespace, the rest the command to be tailcalled. */ + + listPtr = Tcl_NewListObj(objc, objv); nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1); if ((TCL_OK != TclGetNamespaceFromObj(interp, nsObjPtr, &ns1Ptr)) || (nsPtr != ns1Ptr)) { Tcl_Panic("Tailcall failed to find the proper namespace"); } - Tcl_IncrRefCount(nsObjPtr); - - TclNRAddCallback(interp, TclNRTailcallEval, listPtr, nsObjPtr, - NULL, NULL); - tailcallPtr = TOP_CB(interp); - TOP_CB(interp) = tailcallPtr->nextPtr; - iPtr->varFramePtr->tailcallPtr = tailcallPtr; + TclListObjSetElement(interp, listPtr, 0, nsObjPtr); + + iPtr->varFramePtr->tailcallPtr = listPtr; } return TCL_RETURN; } @@ -7825,12 +7837,14 @@ TclNRTailcallEval( int result) { Interp *iPtr = (Interp *) interp; - Tcl_Obj *listPtr = data[0]; - Tcl_Obj *nsObjPtr = data[1]; + Tcl_Obj *listPtr = data[0], *nsObjPtr; Tcl_Namespace *nsPtr; int objc; Tcl_Obj **objv; + Tcl_ListObjGetElements(interp, listPtr, &objc, &objv); + nsObjPtr = objv[0]; + if (result == TCL_OK) { result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr); } @@ -7849,10 +7863,10 @@ TclNRTailcallEval( * Perform the tailcall */ - TclNRDeferCallback(interp, TailcallCleanup, listPtr, nsObjPtr, NULL,NULL); + TclMarkTailcall(interp); + TclNRAddCallback(interp, TailcallCleanup, listPtr, NULL, NULL,NULL); iPtr->lookupNsPtr = (Namespace *) nsPtr; - ListObjGetElements(listPtr, objc, objv); - return TclNREvalObjv(interp, objc, objv, 0, NULL); + return TclNREvalObjv(interp, objc-1, objv+1, 0, NULL); } static int @@ -7862,19 +7876,9 @@ TailcallCleanup( int result) { Tcl_DecrRefCount((Tcl_Obj *) data[0]); - Tcl_DecrRefCount((Tcl_Obj *) data[1]); return result; } -static void -ClearTailcall( - Tcl_Interp *interp, - NRE_callback *tailcallPtr) -{ - TailcallCleanup(tailcallPtr->data, interp, TCL_OK); - TCLNR_FREE(interp, tailcallPtr); -} - void Tcl_NRAddCallback( @@ -7976,50 +7980,32 @@ TclNRYieldToObjCmd( * This is essentially code from TclNRTailcallObjCmd */ - listPtr = Tcl_NewListObj(objc-1, objv+1); - Tcl_IncrRefCount(listPtr); + /* + * Add the tailcall in the caller env, then just yield. + * + * This is essentially code from TclNRTailcallObjCmd + */ + + listPtr = Tcl_NewListObj(objc, objv); 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); + TclListObjSetElement(interp, listPtr, 0, nsObjPtr); + /* * Add the callback in the caller's env, then instruct TEBC to yield. */ iPtr->execEnvPtr = corPtr->callerEEPtr; - TclNRAddCallback(interp, YieldToCallback, corPtr, listPtr, nsObjPtr, - NULL); + TclSetTailcall(interp, listPtr); iPtr->execEnvPtr = corPtr->eePtr; return TclNRYieldObjCmd(INT2PTR(CORO_ACTIVATE_YIELDM), interp, 1, objv); } - -static int -YieldToCallback( - ClientData data[], - Tcl_Interp *interp, - int result) -{ - /* CoroutineData *corPtr = data[0];*/ - Tcl_Obj *listPtr = data[1]; - ClientData nsPtr = data[2]; - NRE_callback *cbPtr; - - /* - * yieldTo: invoke the command using tailcall tech. - */ - - TclNRAddCallback(interp, TclNRTailcallEval, listPtr, nsPtr, NULL, NULL); - cbPtr = TOP_CB(interp); - TOP_CB(interp) = cbPtr->nextPtr; - - TclSpliceTailcall(interp, cbPtr); - return TCL_OK; -} static int RewindCoroutineCallback( @@ -8472,7 +8458,6 @@ TclNRCoroutineObjCmd( corPtr->running.varFramePtr = iPtr->rootFramePtr; corPtr->running.cmdFramePtr = NULL; corPtr->running.lineLABCPtr = corPtr->lineLABCPtr; - corPtr->stackLevel = NULL; corPtr->auxNumLevels = 0; /* @@ -8492,11 +8477,15 @@ TclNRCoroutineObjCmd( TclNRAddCallback(interp, NRCoroutineExitCallback, corPtr, NULL, NULL, NULL); + /* Mark the coro as 'not suspended' while scheduling the command */ + corPtr->stackLevel = INT2PTR(1); + /* insure that the command is looked up in the correct namespace */ iPtr->lookupNsPtr = lookupNsPtr; Tcl_NREvalObj(interp, Tcl_NewListObj(objc-2, objv+2), 0); iPtr->numLevels--; + corPtr->stackLevel = NULL; SAVE_CONTEXT(corPtr->running); RESTORE_CONTEXT(corPtr->caller); iPtr->execEnvPtr = corPtr->callerEEPtr; diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 5c33308..455b5a6 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -128,6 +128,30 @@ static const char B64Digits[65] = { }; /* + * How to construct the ensembles. + */ + +static const EnsembleImplMap binaryMap[] = { + { "format", BinaryFormatCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0 }, + { "scan", BinaryScanCmd, TclCompileBasicMin2ArgCmd, NULL, NULL, 0 }, + { "encode", NULL, NULL, NULL, NULL, 0 }, + { "decode", NULL, NULL, NULL, NULL, 0 }, + { NULL, NULL, NULL, NULL, NULL, 0 } +}; +static const EnsembleImplMap encodeMap[] = { + { "hex", BinaryEncodeHex, TclCompileBasic1ArgCmd, NULL, (ClientData)HexDigits, 0 }, + { "uuencode", BinaryEncode64, NULL, NULL, (ClientData)UueDigits, 0 }, + { "base64", BinaryEncode64, NULL, NULL, (ClientData)B64Digits, 0 }, + { NULL, NULL, NULL, NULL, NULL, 0 } +}; +static const EnsembleImplMap decodeMap[] = { + { "hex", BinaryDecodeHex, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 }, + { "uuencode", BinaryDecodeUu, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 }, + { "base64", BinaryDecode64, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 }, + { NULL, NULL, NULL, NULL, NULL, 0 } +}; + +/* * The following object type represents an array of bytes. An array of bytes * is not equivalent to an internationalized string. Conceptually, a string is * an array of 16-bit quantities organized as a sequence of properly formed @@ -688,26 +712,6 @@ TclAppendBytesToByteArray( *---------------------------------------------------------------------- */ -static const EnsembleImplMap binaryMap[] = { -{ "format", BinaryFormatCmd, NULL, NULL, NULL, 0 }, -{ "scan", BinaryScanCmd, NULL, NULL, NULL, 0 }, -{ "encode", NULL, NULL, NULL, NULL, 0 }, -{ "decode", NULL, NULL, NULL, NULL, 0 }, -{ NULL, NULL, NULL, NULL, NULL, 0 } -}; -static const EnsembleImplMap encodeMap[] = { -{ "hex", BinaryEncodeHex, NULL, NULL, (ClientData)HexDigits, 0 }, -{ "uuencode", BinaryEncode64, NULL, NULL, (ClientData)UueDigits, 0 }, -{ "base64", BinaryEncode64, NULL, NULL, (ClientData)B64Digits, 0 }, -{ NULL, NULL, NULL, NULL, NULL, 0 } -}; -static const EnsembleImplMap decodeMap[] = { -{ "hex", BinaryDecodeHex, NULL, NULL, NULL, 0 }, -{ "uuencode", BinaryDecodeUu, NULL, NULL, NULL, 0 }, -{ "base64", BinaryDecode64, NULL, NULL, NULL, 0 }, -{ NULL, NULL, NULL, NULL, NULL, 0 } -}; - Tcl_Command TclInitBinaryCmd( Tcl_Interp *interp) @@ -2357,7 +2361,7 @@ BinaryDecodeHex( static const char *const optStrings[] = { "-strict", NULL }; if (objc < 2 || objc > 3) { - Tcl_WrongNumArgs(interp, 1, objv, "data"); + Tcl_WrongNumArgs(interp, 1, objv, "?options? data"); return TCL_ERROR; } for (i = 1; i < objc-1; ++i) { @@ -2571,7 +2575,7 @@ BinaryDecodeUu( static const char *const optStrings[] = { "-strict", NULL }; if (objc < 2 || objc > 3) { - Tcl_WrongNumArgs(interp, 1, objv, "data"); + Tcl_WrongNumArgs(interp, 1, objv, "?options? data"); return TCL_ERROR; } for (i = 1; i < objc-1; ++i) { @@ -2667,7 +2671,7 @@ BinaryDecode64( static const char *const optStrings[] = { "-strict", NULL }; if (objc < 2 || objc > 3) { - Tcl_WrongNumArgs(interp, 1, objv, "data"); + Tcl_WrongNumArgs(interp, 1, objv, "?options? data"); return TCL_ERROR; } for (i = 1; i < objc-1; ++i) { diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c index ab977cb..70e64f0 100644 --- a/generic/tclCkalloc.c +++ b/generic/tclCkalloc.c @@ -156,6 +156,10 @@ TclInitDbCkalloc(void) if (!ckallocInit) { ckallocInit = 1; ckallocMutexPtr = Tcl_GetAllocMutex(); +#ifndef TCL_THREADS + /* Silence compiler warning */ + (void)ckallocMutexPtr; +#endif } } diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index ee1f97a..8468356 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -11,6 +11,7 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ +#include <sys/stat.h> #include "tclInt.h" #include <locale.h> @@ -224,7 +225,8 @@ CatchObjCmdCallback( if (NULL == Tcl_ObjSetVar2(interp, optionVarNamePtr, NULL, options, TCL_LEAVE_ERR_MSG)) { - Tcl_DecrRefCount(options); + /* Do not decrRefCount 'options', it was already done by + * Tcl_ObjSetVar2 */ return TCL_ERROR; } } @@ -812,40 +814,40 @@ TclInitFileCmd( */ static const EnsembleImplMap initMap[] = { - {"atime", FileAttrAccessTimeCmd, NULL, NULL, NULL, 0}, - {"attributes", TclFileAttrsCmd, NULL, NULL, NULL, 0}, - {"channels", TclChannelNamesCmd, NULL, NULL, NULL, 0}, - {"copy", TclFileCopyCmd, NULL, NULL, NULL, 0}, - {"delete", TclFileDeleteCmd, NULL, NULL, NULL, 0}, - {"dirname", PathDirNameCmd, NULL, NULL, NULL, 0}, - {"executable", FileAttrIsExecutableCmd, NULL, NULL, NULL, 0}, - {"exists", FileAttrIsExistingCmd, NULL, NULL, NULL, 0}, - {"extension", PathExtensionCmd, NULL, NULL, NULL, 0}, - {"isdirectory", FileAttrIsDirectoryCmd, NULL, NULL, NULL, 0}, - {"isfile", FileAttrIsFileCmd, NULL, NULL, NULL, 0}, - {"join", PathJoinCmd, NULL, NULL, NULL, 0}, - {"link", TclFileLinkCmd, NULL, NULL, NULL, 0}, - {"lstat", FileAttrLinkStatCmd, NULL, NULL, NULL, 0}, - {"mtime", FileAttrModifyTimeCmd, NULL, NULL, NULL, 0}, - {"mkdir", TclFileMakeDirsCmd, NULL, NULL, NULL, 0}, - {"nativename", PathNativeNameCmd, NULL, NULL, NULL, 0}, - {"normalize", PathNormalizeCmd, NULL, NULL, NULL, 0}, - {"owned", FileAttrIsOwnedCmd, NULL, NULL, NULL, 0}, - {"pathtype", PathTypeCmd, NULL, NULL, NULL, 0}, - {"readable", FileAttrIsReadableCmd, NULL, NULL, NULL, 0}, - {"readlink", TclFileReadLinkCmd, NULL, NULL, NULL, 0}, - {"rename", TclFileRenameCmd, NULL, NULL, NULL, 0}, - {"rootname", PathRootNameCmd, NULL, NULL, NULL, 0}, - {"separator", FilesystemSeparatorCmd, NULL, NULL, NULL, 0}, - {"size", FileAttrSizeCmd, NULL, NULL, NULL, 0}, - {"split", PathSplitCmd, NULL, NULL, NULL, 0}, - {"stat", FileAttrStatCmd, NULL, NULL, NULL, 0}, - {"system", PathFilesystemCmd, NULL, NULL, NULL, 0}, - {"tail", PathTailCmd, NULL, NULL, NULL, 0}, - {"tempfile", TclFileTemporaryCmd, NULL, NULL, NULL, 0}, - {"type", FileAttrTypeCmd, NULL, NULL, NULL, 0}, - {"volumes", FilesystemVolumesCmd, NULL, NULL, NULL, 0}, - {"writable", FileAttrIsWritableCmd, NULL, NULL, NULL, 0}, + {"atime", FileAttrAccessTimeCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, + {"attributes", TclFileAttrsCmd, NULL, NULL, NULL, 0}, + {"channels", TclChannelNamesCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, + {"copy", TclFileCopyCmd, NULL, NULL, NULL, 0}, + {"delete", TclFileDeleteCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0}, + {"dirname", PathDirNameCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"executable", FileAttrIsExecutableCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"exists", FileAttrIsExistingCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"extension", PathExtensionCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"isdirectory", FileAttrIsDirectoryCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"isfile", FileAttrIsFileCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"join", PathJoinCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0}, + {"link", TclFileLinkCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0}, + {"lstat", FileAttrLinkStatCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, + {"mtime", FileAttrModifyTimeCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, + {"mkdir", TclFileMakeDirsCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0}, + {"nativename", PathNativeNameCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"normalize", PathNormalizeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"owned", FileAttrIsOwnedCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"pathtype", PathTypeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"readable", FileAttrIsReadableCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"readlink", TclFileReadLinkCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"rename", TclFileRenameCmd, NULL, NULL, NULL, 0}, + {"rootname", PathRootNameCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"separator", FilesystemSeparatorCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, + {"size", FileAttrSizeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"split", PathSplitCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"stat", FileAttrStatCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, + {"system", PathFilesystemCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, + {"tail", PathTailCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"tempfile", TclFileTemporaryCmd, TclCompileBasic0To2ArgCmd, NULL, NULL, 0}, + {"type", FileAttrTypeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"volumes", FilesystemVolumesCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, + {"writable", FileAttrIsWritableCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {NULL, NULL, NULL, NULL, NULL, 0} }; return TclMakeEnsemble(interp, "file", initMap); diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 155e8e4..c70ba23 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -161,30 +161,30 @@ static Tcl_Obj * SelectObjFromSublist(Tcl_Obj *firstPtr, */ static const EnsembleImplMap defaultInfoMap[] = { - {"args", InfoArgsCmd, NULL, NULL, NULL, 0}, - {"body", InfoBodyCmd, NULL, NULL, NULL, 0}, - {"cmdcount", InfoCmdCountCmd, NULL, NULL, NULL, 0}, + {"args", InfoArgsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"body", InfoBodyCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"cmdcount", InfoCmdCountCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, {"commands", InfoCommandsCmd, TclCompileInfoCommandsCmd, NULL, NULL, 0}, - {"complete", InfoCompleteCmd, NULL, NULL, NULL, 0}, + {"complete", InfoCompleteCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"coroutine", TclInfoCoroutineCmd, TclCompileInfoCoroutineCmd, NULL, NULL, 0}, - {"default", InfoDefaultCmd, NULL, NULL, NULL, 0}, - {"errorstack", InfoErrorStackCmd, NULL, NULL, NULL, 0}, + {"default", InfoDefaultCmd, TclCompileBasic3ArgCmd, NULL, NULL, 0}, + {"errorstack", InfoErrorStackCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, {"exists", TclInfoExistsCmd, TclCompileInfoExistsCmd, NULL, NULL, 0}, - {"frame", InfoFrameCmd, NULL, NULL, NULL, 0}, - {"functions", InfoFunctionsCmd, NULL, NULL, NULL, 0}, - {"globals", TclInfoGlobalsCmd, NULL, NULL, NULL, 0}, - {"hostname", InfoHostnameCmd, NULL, NULL, NULL, 0}, + {"frame", InfoFrameCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, + {"functions", InfoFunctionsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, + {"globals", TclInfoGlobalsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, + {"hostname", InfoHostnameCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, {"level", InfoLevelCmd, TclCompileInfoLevelCmd, NULL, NULL, 0}, - {"library", InfoLibraryCmd, NULL, NULL, NULL, 0}, - {"loaded", InfoLoadedCmd, NULL, NULL, NULL, 0}, - {"locals", TclInfoLocalsCmd, NULL, NULL, NULL, 0}, - {"nameofexecutable", InfoNameOfExecutableCmd, NULL, NULL, NULL, 0}, - {"patchlevel", InfoPatchLevelCmd, NULL, NULL, NULL, 0}, - {"procs", InfoProcsCmd, NULL, NULL, NULL, 0}, - {"script", InfoScriptCmd, NULL, NULL, NULL, 0}, - {"sharedlibextension", InfoSharedlibCmd, NULL, NULL, NULL, 0}, - {"tclversion", InfoTclVersionCmd, NULL, NULL, NULL, 0}, - {"vars", TclInfoVarsCmd, NULL, NULL, NULL, 0}, + {"library", InfoLibraryCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, + {"loaded", InfoLoadedCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, + {"locals", TclInfoLocalsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, + {"nameofexecutable", InfoNameOfExecutableCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, + {"patchlevel", InfoPatchLevelCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, + {"procs", InfoProcsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, + {"script", InfoScriptCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, + {"sharedlibextension", InfoSharedlibCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, + {"tclversion", InfoTclVersionCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, + {"vars", TclInfoVarsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, {NULL, NULL, NULL, NULL, NULL, 0} }; diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index fc957c4..95debf8 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -3324,7 +3324,7 @@ TclInitStringCmd( Tcl_Interp *interp) /* Current interpreter. */ { static const EnsembleImplMap stringImplMap[] = { - {"bytelength", StringBytesCmd, NULL, NULL, NULL, 0}, + {"bytelength", StringBytesCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"compare", StringCmpCmd, TclCompileStringCmpCmd, NULL, NULL, 0}, {"equal", StringEqualCmd, TclCompileStringEqualCmd, NULL, NULL, 0}, {"first", StringFirstCmd, TclCompileStringFirstCmd, NULL, NULL, 0}, @@ -3335,17 +3335,17 @@ TclInitStringCmd( {"map", StringMapCmd, TclCompileStringMapCmd, NULL, NULL, 0}, {"match", StringMatchCmd, TclCompileStringMatchCmd, NULL, NULL, 0}, {"range", StringRangeCmd, TclCompileStringRangeCmd, NULL, NULL, 0}, - {"repeat", StringReptCmd, NULL, NULL, NULL, 0}, + {"repeat", StringReptCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"replace", StringRplcCmd, NULL, NULL, NULL, 0}, - {"reverse", StringRevCmd, NULL, NULL, NULL, 0}, - {"tolower", StringLowerCmd, NULL, NULL, NULL, 0}, - {"toupper", StringUpperCmd, NULL, NULL, NULL, 0}, - {"totitle", StringTitleCmd, NULL, NULL, NULL, 0}, - {"trim", StringTrimCmd, NULL, NULL, NULL, 0}, - {"trimleft", StringTrimLCmd, NULL, NULL, NULL, 0}, - {"trimright", StringTrimRCmd, NULL, NULL, NULL, 0}, - {"wordend", StringEndCmd, NULL, NULL, NULL, 0}, - {"wordstart", StringStartCmd, NULL, NULL, NULL, 0}, + {"reverse", StringRevCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"tolower", StringLowerCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0}, + {"toupper", StringUpperCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0}, + {"totitle", StringTitleCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0}, + {"trim", StringTrimCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, + {"trimleft", StringTrimLCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, + {"trimright", StringTrimRCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, + {"wordend", StringEndCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, + {"wordstart", StringStartCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {NULL, NULL, NULL, NULL, NULL, 0} }; diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 3bd60ab..4549753 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -193,8 +193,8 @@ TclCompileArrayExistsCmd( } tokenPtr = TokenAfter(parsePtr->tokenPtr); - PUSH_VAR( tokenPtr, 1, - &localIndex, &simpleVarName, &isScalar); + PushVarNameWord(interp, tokenPtr, envPtr, TCL_NO_ELEMENT, + &localIndex, &simpleVarName, &isScalar, 1); if (!isScalar) { return TCL_ERROR; } @@ -228,12 +228,12 @@ TclCompileArraySetCmd( } tokenPtr = TokenAfter(parsePtr->tokenPtr); - PUSH_VAR( tokenPtr, 1, - &localIndex, &simpleVarName, &isScalar); + PushVarNameWord(interp, tokenPtr, envPtr, TCL_NO_ELEMENT, + &localIndex, &simpleVarName, &isScalar, 1); + tokenPtr = TokenAfter(tokenPtr); if (!isScalar) { return TCL_ERROR; } - tokenPtr = TokenAfter(tokenPtr); /* * Special case: literal empty value argument is just an "ensure array" @@ -259,13 +259,33 @@ TclCompileArraySetCmd( return TCL_OK; } + if (envPtr->procPtr == NULL) { + /* + * Right number of arguments, but not compilable as we can't allocate + * (unnamed) local variables to manage the internal iteration. + */ + + Tcl_Obj *objPtr = Tcl_NewObj(); + char *bytes; + int length, cmdLit; + + Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr); + bytes = Tcl_GetStringFromObj(objPtr, &length); + cmdLit = TclRegisterNewCmdLiteral(envPtr, bytes, length); + TclSetCmdNameObj(interp, envPtr->literalArrayPtr[cmdLit].objPtr, + cmdPtr); + TclEmitPush(cmdLit, envPtr); + TclDecrRefCount(objPtr); + OP( EXCH); + PUSH_SUBST_WORD(tokenPtr, 2); + OP4( INVOKE_STK, 3); + return TCL_OK; + } + /* * Prepare for the internal foreach. */ - if (envPtr->procPtr == NULL) { - return TCL_ERROR; - } dataVar = NewUnnamedLocal(envPtr); iterVar = NewUnnamedLocal(envPtr); keyVar = NewUnnamedLocal(envPtr); @@ -356,11 +376,11 @@ TclCompileArrayUnsetCmd( int simpleVarName, isScalar, localIndex, savedStackDepth; if (parsePtr->numWords != 2) { - return TCL_ERROR; + return TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr); } - PUSH_VAR( tokenPtr, 1, - &localIndex, &simpleVarName, &isScalar); + PushVarNameWord(interp, tokenPtr, envPtr, TCL_NO_ELEMENT, + &localIndex, &simpleVarName, &isScalar, 1); if (!isScalar) { return TCL_ERROR; } @@ -847,7 +867,7 @@ TclCompileDictIncrCmd( incrTokenPtr = TokenAfter(keyTokenPtr); if (incrTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; + return TclCompileBasic2Or3ArgCmd(interp, parsePtr,cmdPtr, envPtr); } word = incrTokenPtr[1].start; numBytes = incrTokenPtr[1].size; @@ -857,7 +877,7 @@ TclCompileDictIncrCmd( code = TclGetIntFromObj(NULL, intObj, &incrAmount); TclDecrRefCount(intObj); if (code != TCL_OK) { - return TCL_ERROR; + return TclCompileBasic2Or3ArgCmd(interp, parsePtr,cmdPtr, envPtr); } } else { incrAmount = 1; @@ -870,16 +890,16 @@ TclCompileDictIncrCmd( */ if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; + return TclCompileBasic2Or3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } name = varTokenPtr[1].start; nameChars = varTokenPtr[1].size; if (!TclIsLocalScalar(name, nameChars)) { - return TCL_ERROR; + return TclCompileBasic2Or3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr); if (dictVarIndex < 0) { - return TCL_ERROR; + return TclCompileBasic2Or3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } /* @@ -996,16 +1016,16 @@ TclCompileDictUnsetCmd( tokenPtr = TokenAfter(parsePtr->tokenPtr); if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; + return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr); } name = tokenPtr[1].start; nameChars = tokenPtr[1].size; if (!TclIsLocalScalar(name, nameChars)) { - return TCL_ERROR; + return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr); } dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr); if (dictVarIndex < 0) { - return TCL_ERROR; + return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr); } /* @@ -1093,7 +1113,7 @@ TclCompileDictCreateCmd( nonConstant: worker = NewUnnamedLocal(envPtr); if (worker < 0) { - return TCL_ERROR; + return TclCompileBasicMin0ArgCmd(interp, parsePtr, cmdPtr, envPtr); } PUSH( ""); @@ -1152,7 +1172,7 @@ TclCompileDictMergeCmd( workerIndex = NewUnnamedLocal(envPtr); if (workerIndex < 0) { - return TCL_ERROR; + return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr); } infoIndex = NewUnnamedLocal(envPtr); @@ -1276,11 +1296,11 @@ CompileDictEachCmd( Tcl_DString buffer; /* - * There must be at least three argument after the command. + * There must be three arguments after the command. */ if (parsePtr->numWords != 4) { - return TCL_ERROR; + return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } varsTokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -1288,7 +1308,7 @@ CompileDictEachCmd( bodyTokenPtr = TokenAfter(dictTokenPtr); if (varsTokenPtr->type != TCL_TOKEN_SIMPLE_WORD || bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; + return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } /* @@ -1299,7 +1319,7 @@ CompileDictEachCmd( if (collect == TCL_EACH_COLLECT) { collectVar = NewUnnamedLocal(envPtr); if (collectVar < 0) { - return TCL_ERROR; + return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } } @@ -1313,31 +1333,31 @@ CompileDictEachCmd( if (Tcl_SplitList(NULL, Tcl_DStringValue(&buffer), &numVars, &argv) != TCL_OK) { Tcl_DStringFree(&buffer); - return TCL_ERROR; + return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } Tcl_DStringFree(&buffer); if (numVars != 2) { ckfree(argv); - return TCL_ERROR; + return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } nameChars = strlen(argv[0]); if (!TclIsLocalScalar(argv[0], nameChars)) { ckfree(argv); - return TCL_ERROR; + return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } keyVarIndex = TclFindCompiledLocal(argv[0], nameChars, 1, envPtr); nameChars = strlen(argv[1]); if (!TclIsLocalScalar(argv[1], nameChars)) { ckfree(argv); - return TCL_ERROR; + return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } valueVarIndex = TclFindCompiledLocal(argv[1], nameChars, 1, envPtr); ckfree(argv); if ((keyVarIndex < 0) || (valueVarIndex < 0)) { - return TCL_ERROR; + return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } /* @@ -1349,7 +1369,7 @@ CompileDictEachCmd( infoIndex = NewUnnamedLocal(envPtr); if (infoIndex < 0) { - return TCL_ERROR; + return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } /* @@ -1532,16 +1552,16 @@ TclCompileDictUpdateCmd( dictVarTokenPtr = TokenAfter(parsePtr->tokenPtr); if (dictVarTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; + return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr); } name = dictVarTokenPtr[1].start; nameChars = dictVarTokenPtr[1].size; if (!TclIsLocalScalar(name, nameChars)) { - return TCL_ERROR; + return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr); } dictIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr); if (dictIndex < 0) { - return TCL_ERROR; + return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr); } /* @@ -1592,7 +1612,7 @@ TclCompileDictUpdateCmd( failedUpdateInfoAssembly: ckfree(duiPtr); TclStackFree(interp, keyTokenPtrs); - return TCL_ERROR; + return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr); } bodyTokenPtr = tokenPtr; @@ -1686,17 +1706,17 @@ TclCompileDictAppendCmd( tokenPtr = TokenAfter(parsePtr->tokenPtr); if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; + return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr); } else { register const char *name = tokenPtr[1].start; register int nameChars = tokenPtr[1].size; if (!TclIsLocalScalar(name, nameChars)) { - return TCL_ERROR; + return TclCompileBasicMin2ArgCmd(interp, parsePtr,cmdPtr, envPtr); } dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr); if (dictVarIndex < 0) { - return TCL_ERROR; + return TclCompileBasicMin2ArgCmd(interp, parsePtr,cmdPtr, envPtr); } } @@ -1747,16 +1767,16 @@ TclCompileDictLappendCmd( keyTokenPtr = TokenAfter(varTokenPtr); valueTokenPtr = TokenAfter(keyTokenPtr); if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; + return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } name = varTokenPtr[1].start; nameChars = varTokenPtr[1].size; if (!TclIsLocalScalar(name, nameChars)) { - return TCL_ERROR; + return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr); if (dictVarIndex < 0) { - return TCL_ERROR; + return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } PUSH_SUBST_WORD(keyTokenPtr, 3); PUSH_SUBST_WORD(valueTokenPtr, 4); @@ -1800,7 +1820,7 @@ TclCompileDictWithCmd( tokenPtr = TokenAfter(tokenPtr); } if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; + return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr); } /* @@ -1812,7 +1832,8 @@ TclCompileDictWithCmd( for (ptr=tokenPtr[1].start,end=ptr+tokenPtr[1].size ; ptr!=end ; ptr++) { if (*ptr!=' ' && *ptr!='\t' && *ptr!='\n' && *ptr!='\r') { if (envPtr->procPtr == NULL) { - return TCL_ERROR; + return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, + envPtr); } bodyIsEmpty = 0; break; @@ -2936,7 +2957,7 @@ TclCompileFormatCmd( * after our attempt to spot a literal). */ - for (; --i>=0 ;) { + for (; i>=0 ; i--) { Tcl_DecrRefCount(objv[i]); } ckfree(objv); @@ -3590,7 +3611,9 @@ TclCompileInfoCommandsCmd( * We require one compile-time known argument for the case we can compile. */ - if (parsePtr->numWords != 2) { + if (parsePtr->numWords == 1) { + return TclCompileBasic0ArgCmd(interp, parsePtr, cmdPtr, envPtr); + } else if (parsePtr->numWords != 2) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -3627,7 +3650,7 @@ TclCompileInfoCommandsCmd( notCompilable: Tcl_DecrRefCount(objPtr); - return TCL_ERROR; + return TclCompileBasic1ArgCmd(interp, parsePtr, cmdPtr, envPtr); } int @@ -5624,7 +5647,7 @@ TclCompileVariableCmd( */ valueTokenPtr = parsePtr->tokenPtr; - for (i=2; i<=numWords; i+=2) { + for (i=1; i<numWords; i+=2) { varTokenPtr = TokenAfter(valueTokenPtr); valueTokenPtr = TokenAfter(varTokenPtr); @@ -5637,7 +5660,7 @@ TclCompileVariableCmd( PUSH_SUBST_WORD(varTokenPtr, i-1); OP4( VARIABLE, localIndex); - if (i != numWords) { + if (i+1 < numWords) { /* * A value has been given: set the variable, pop the value */ diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index ba6216b..2c090ff 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -364,7 +364,7 @@ TclCompileStringMatchCmd( if (parsePtr->numWords == 4) { if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; + return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } str = tokenPtr[1].start; length = tokenPtr[1].size; @@ -373,7 +373,7 @@ TclCompileStringMatchCmd( * Fail at run time, not in compilation. */ - return TCL_ERROR; + return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } nocase = 1; tokenPtr = TokenAfter(tokenPtr); @@ -490,13 +490,13 @@ TclCompileStringMapCmd( Tcl_IncrRefCount(mapObj); if (!TclWordKnownAtCompileTime(mapTokenPtr, mapObj)) { Tcl_DecrRefCount(mapObj); - return TCL_ERROR; + return TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr); } else if (Tcl_ListObjGetElements(NULL, mapObj, &len, &objv) != TCL_OK) { Tcl_DecrRefCount(mapObj); - return TCL_ERROR; + return TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr); } else if (len != 2) { Tcl_DecrRefCount(mapObj); - return TCL_ERROR; + return TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr); } /* @@ -746,6 +746,34 @@ TclSubstCompile( TclEmitPush(literal, envPtr); count++; continue; + case TCL_TOKEN_VARIABLE: + /* + * Check for simple variable access; see if we can only generate + * TCL_OK or TCL_ERROR from the substituted variable read; if so, + * there is no need to generate elaborate exception-management + * code. Note that the first component of TCL_TOKEN_VARIABLE is + * always TCL_TOKEN_TEXT... + */ + + if (tokenPtr->numComponents > 1) { + int i, foundCommand = 0; + + for (i=2 ; i<=tokenPtr->numComponents ; i++) { + if (tokenPtr[i].type == TCL_TOKEN_COMMAND) { + foundCommand = 1; + break; + } + } + if (foundCommand) { + break; + } + } + + envPtr->line = bline; + TclCompileVarSubst(interp, tokenPtr, envPtr); + bline = envPtr->line; + count++; + continue; } while (count > 255) { @@ -1787,16 +1815,18 @@ TclCompileTailcallCmd( Tcl_Token *tokenPtr = parsePtr->tokenPtr; int i; - if (parsePtr->numWords < 2 || parsePtr->numWords > 256 + if (parsePtr->numWords < 2 || parsePtr->numWords > 255 || envPtr->procPtr == NULL) { return TCL_ERROR; } + /* make room for the nsObjPtr */ + CompileWord(envPtr, tokenPtr, interp, 0); for (i=1 ; i<parsePtr->numWords ; i++) { tokenPtr = TokenAfter(tokenPtr); PUSH_SUBST_WORD(tokenPtr, i); } - OP1( TAILCALL, parsePtr->numWords-1); + OP1( TAILCALL, parsePtr->numWords); return TCL_OK; } @@ -2579,7 +2609,7 @@ TclCompileUnsetCmd( flags = 1; varTokenPtr = TokenAfter(parsePtr->tokenPtr); leadingWord = Tcl_NewObj(); - if (TclWordKnownAtCompileTime(varTokenPtr, leadingWord)) { + if (numWords > 0 && TclWordKnownAtCompileTime(varTokenPtr, leadingWord)) { int len; const char *bytes = Tcl_GetStringFromObj(leadingWord, &len); diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 3bc2afa..86de4bc 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -498,6 +498,10 @@ InstructionDesc const tclInstructionTable[] = { {"under", 1, +1, 0, {OPERAND_NONE}}, /* Duplicates the item under the top of the stack. * Stack: ... a b => ... a b a */ + {"invokeReplace", 6, INT_MIN, 2, {OPERAND_UINT4,OPERAND_UINT1}}, + /* Invoke command named objv[0], replacing the first two words with + * the word at the top of the stack; + * <objc,objv> = <op4,top op4 after popping 1> */ {NULL, 0, 0, 0, {OPERAND_NONE}} }; @@ -2420,7 +2424,7 @@ TclPushVarName( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Token *varTokenPtr, /* Points to a variable token. */ CompileEnv *envPtr, /* Holds resulting instructions. */ - int flags, /* TCL_NO_LARGE_INDEX. */ + int flags, /* TCL_NO_LARGE_INDEX | TCL_NO_ELEMENT. */ int *localIndexPtr, /* Must not be NULL. */ int *simpleVarNamePtr, /* Must not be NULL. */ int *isScalarPtr, /* Must not be NULL. */ @@ -2604,7 +2608,7 @@ TclPushVarName( * Compile the element script, if any. */ - if (elName != NULL) { + if (elName != NULL && !(flags & TCL_NO_ELEMENT)) { if (elNameChars) { envPtr->line = line; envPtr->clNext = clNext; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index bc16865..6171a49 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -667,9 +667,10 @@ typedef struct ByteCode { #define INST_EXCH 145 #define INST_UNDER 146 +#define INST_INVOKE_REPLACE 147 /* The last opcode */ -#define LAST_INST_OPCODE 146 +#define LAST_INST_OPCODE 147 /* * Table describing the Tcl bytecode instructions: their name (for displaying @@ -1411,6 +1412,7 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); */ #define TCL_NO_LARGE_INDEX 1 /* Do not return localIndex value > 255 */ +#define TCL_NO_ELEMENT 2 /* Do not push the array element. */ /* * Shorthand macros for instruction issuing. Note that these assume that there diff --git a/generic/tclDecls.h b/generic/tclDecls.h index d38296d..030bca7 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -3744,4 +3744,16 @@ TCLAPI void Tcl_MainExW(int argc, wchar_t **argv, Tcl_AppInitProc *appInitProc, Tcl_Interp *interp); #endif +/* + * Deprecated Tcl procedures: + */ +#if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) +# undef Tcl_EvalObj +# define Tcl_EvalObj(interp,objPtr) \ + Tcl_EvalObjEx((interp),(objPtr),0) +# undef Tcl_GlobalEvalObj +# define Tcl_GlobalEvalObj(interp,objPtr) \ + Tcl_EvalObjEx((interp),(objPtr),TCL_EVAL_GLOBAL) +#endif + #endif /* _TCLDECLS */ diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index eb3625e..170e744 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -91,22 +91,22 @@ static const EnsembleImplMap implementationMap[] = { {"append", DictAppendCmd, TclCompileDictAppendCmd, NULL, NULL, 0 }, {"create", DictCreateCmd, TclCompileDictCreateCmd, NULL, NULL, 0 }, {"exists", DictExistsCmd, TclCompileDictExistsCmd, NULL, NULL, 0 }, - {"filter", DictFilterCmd, NULL, NULL, NULL, 0 }, + {"filter", DictFilterCmd, NULL, NULL, NULL, 0 }, {"for", NULL, TclCompileDictForCmd, DictForNRCmd, NULL, 0 }, {"get", DictGetCmd, TclCompileDictGetCmd, NULL, NULL, 0 }, {"incr", DictIncrCmd, TclCompileDictIncrCmd, NULL, NULL, 0 }, - {"info", DictInfoCmd, NULL, NULL, NULL, 0 }, - {"keys", DictKeysCmd, NULL, NULL, NULL, 0 }, + {"info", DictInfoCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0 }, + {"keys", DictKeysCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 }, {"lappend", DictLappendCmd, TclCompileDictLappendCmd, NULL, NULL, 0 }, {"map", NULL, TclCompileDictMapCmd, DictMapNRCmd, NULL, 0 }, {"merge", DictMergeCmd, TclCompileDictMergeCmd, NULL, NULL, 0 }, - {"remove", DictRemoveCmd, NULL, NULL, NULL, 0 }, + {"remove", DictRemoveCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0 }, {"replace", DictReplaceCmd, NULL, NULL, NULL, 0 }, {"set", DictSetCmd, TclCompileDictSetCmd, NULL, NULL, 0 }, - {"size", DictSizeCmd, NULL, NULL, NULL, 0 }, + {"size", DictSizeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0 }, {"unset", DictUnsetCmd, TclCompileDictUnsetCmd, NULL, NULL, 0 }, {"update", DictUpdateCmd, TclCompileDictUpdateCmd, NULL, NULL, 0 }, - {"values", DictValuesCmd, NULL, NULL, NULL, 0 }, + {"values", DictValuesCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 }, {"with", DictWithCmd, TclCompileDictWithCmd, NULL, NULL, 0 }, {NULL, NULL, NULL, NULL, NULL, 0} }; diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index d2c7bc8..5bde14e 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -9,6 +9,7 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ +#include <sys/stat.h> #include "tclInt.h" typedef size_t (LengthProc)(const char *src); diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index b76c603..efa6339 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -4,7 +4,7 @@ * Contains support for ensembles (see TIP#112), which provide simple * mechanism for creating composite commands on top of namespaces. * - * Copyright (c) 2005-2010 Donal K. Fellows. + * Copyright (c) 2005-2013 Donal K. Fellows. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -35,6 +35,15 @@ static void MakeCachedEnsembleCommand(Tcl_Obj *objPtr, static void FreeEnsembleCmdRep(Tcl_Obj *objPtr); static void DupEnsembleCmdRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); static void StringOfEnsembleCmdRep(Tcl_Obj *objPtr); +static int CompileToCompiledCommand(Tcl_Interp *interp, + Tcl_Parse *parsePtr, int depth, Command *cmdPtr, + CompileEnv *envPtr); +static void CompileToInvokedCommand(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Tcl_Obj *replacements, + Command *cmdPtr, CompileEnv *envPtr); +static int CompileBasicNArgCommand(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + CompileEnv *envPtr); /* * The lists of subcommands and options for the [namespace ensemble] command. @@ -1565,21 +1574,23 @@ TclMakeEnsemble( NULL); } cmdPtr->compileProc = map[i].compileProc; - if (map[i].compileProc != NULL) { - ensembleFlags |= ENSEMBLE_COMPILE; - } } } Tcl_SetEnsembleMappingDict(interp, ensemble, mapDict); - if (ensembleFlags & ENSEMBLE_COMPILE) { - Tcl_SetEnsembleFlags(interp, ensemble, ensembleFlags); - } + + /* + * Switch on compilation always for core ensembles now that we can do + * nice bytecode things with them. + */ + + Tcl_SetEnsembleFlags(interp, ensemble, + ensembleFlags | ENSEMBLE_COMPILE); } Tcl_DStringFree(&buf); Tcl_DStringFree(&hiddenBuf); if (nameParts != NULL) { - Tcl_Free((char *) nameParts); + ckfree((char *) nameParts); } return ensemble; } @@ -1892,7 +1903,7 @@ NsEnsembleImplementationCmdNR( * Hand off to the target command. */ - iPtr->evalFlags |= TCL_EVAL_REDIRECT; + TclSkipTailcall(interp); return TclNREvalObjEx(interp, copyPtr, TCL_EVAL_INVOKE, NULL,INT_MIN); } @@ -2100,7 +2111,7 @@ EnsembleUnknownCallback( */ Tcl_Preserve(ensemblePtr); - ((Interp *) interp)->evalFlags |= TCL_EVAL_REDIRECT; + TclSkipTailcall(interp); result = Tcl_EvalObjv(interp, paramc, paramv, 0); if ((result == TCL_OK) && (ensemblePtr->flags & ENSEMBLE_DEAD)) { if (!Tcl_InterpDeleted(interp)) { @@ -2174,7 +2185,7 @@ EnsembleUnknownCallback( } Tcl_AddErrorInfo(interp, "\n result of " "ensemble unknown subcommand handler: "); - Tcl_AddErrorInfo(interp, TclGetString(unknownCmd)); + Tcl_AppendObjToErrorInfo(interp, unknownCmd); Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "UNKNOWN_RESULT", NULL); } else { @@ -2731,25 +2742,33 @@ TclCompileEnsemble( * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { - Tcl_Token *tokenPtr; + Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); Tcl_Obj *mapObj, *subcmdObj, *targetCmdObj, *listObj, **elems; + Tcl_Obj *replaced = Tcl_NewObj(), *replacement; Tcl_Command ensemble = (Tcl_Command) cmdPtr; - Tcl_Parse synthetic; - int len, result, flags = 0, i; + Command *oldCmdPtr = cmdPtr, *newCmdPtr; + int len, result, flags = 0, i, depth = 1, invokeAnyway = 0; + int ourResult = TCL_ERROR; unsigned numBytes; const char *word; - if (parsePtr->numWords < 2) { - return TCL_ERROR; - } + Tcl_IncrRefCount(replaced); - tokenPtr = TokenAfter(parsePtr->tokenPtr); + /* + * This is where we return to if we are parsing multiple nested compiled + * ensembles. [info object] is such a beast. + */ + + checkNextWord: + if (parsePtr->numWords < depth + 1) { + goto failed; + } if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { /* * Too hard. */ - return TCL_ERROR; + goto failed; } word = tokenPtr[1].start; @@ -2768,7 +2787,7 @@ TclCompileEnsemble( * to proceed. */ - return TCL_ERROR; + goto failed; } /* @@ -2782,7 +2801,7 @@ TclCompileEnsemble( * Figuring out how to compile this has become too much. Bail out. */ - return TCL_ERROR; + goto failed; } /* @@ -2805,7 +2824,7 @@ TclCompileEnsemble( Tcl_Obj *matchObj = NULL; if (Tcl_ListObjGetElements(NULL, listObj, &len, &elems) != TCL_OK) { - return TCL_ERROR; + goto failed; } for (i=0 ; i<len ; i++) { str = Tcl_GetStringFromObj(elems[i], &sclen); @@ -2816,8 +2835,9 @@ TclCompileEnsemble( result = Tcl_DictObjGet(NULL, mapObj,elems[i], &targetCmdObj); if (result != TCL_OK || targetCmdObj == NULL) { - return TCL_ERROR; + goto failed; } + replacement = elems[i]; goto doneMapLookup; } @@ -2833,18 +2853,19 @@ TclCompileEnsemble( if ((flags & TCL_ENSEMBLE_PREFIX) && strncmp(word, str, numBytes) == 0) { if (matchObj != NULL) { - return TCL_ERROR; + goto failed; } matchObj = elems[i]; } } if (matchObj == NULL) { - return TCL_ERROR; + goto failed; } result = Tcl_DictObjGet(NULL, mapObj, matchObj, &targetCmdObj); if (result != TCL_OK || targetCmdObj == NULL) { - return TCL_ERROR; + goto failed; } + replacement = matchObj; } else { Tcl_DictSearch s; int done, matched; @@ -2856,14 +2877,15 @@ TclCompileEnsemble( TclNewStringObj(subcmdObj, word, (int) numBytes); result = Tcl_DictObjGet(NULL, mapObj, subcmdObj, &targetCmdObj); - TclDecrRefCount(subcmdObj); if (result == TCL_OK && targetCmdObj != NULL) { /* * Got it. Skip the fiddling around with prefixes. */ + replacement = subcmdObj; goto doneMapLookup; } + TclDecrRefCount(subcmdObj); /* * We've not literally got a valid subcommand. But maybe we have a @@ -2871,7 +2893,7 @@ TclCompileEnsemble( */ if (!(flags & TCL_ENSEMBLE_PREFIX)) { - return TCL_ERROR; + goto failed; } /* @@ -2881,6 +2903,7 @@ TclCompileEnsemble( Tcl_DictObjFirst(NULL, mapObj, &s, &subcmdObj, &tmpObj, &done); matched = 0; + replacement = NULL; /* Silence, fool compiler! */ while (!done) { if (strncmp(TclGetString(subcmdObj), word, numBytes) == 0) { if (matched++) { @@ -2891,6 +2914,7 @@ TclCompileEnsemble( break; } + replacement = subcmdObj; targetCmdObj = tmpObj; } Tcl_DictObjNext(&s, &subcmdObj, &tmpObj, &done); @@ -2903,7 +2927,8 @@ TclCompileEnsemble( */ if (matched != 1) { - return TCL_ERROR; + invokeAnyway = 1; + goto failed; } } @@ -2917,75 +2942,157 @@ TclCompileEnsemble( */ doneMapLookup: + Tcl_ListObjAppendElement(NULL, replaced, replacement); if (Tcl_ListObjGetElements(NULL, targetCmdObj, &len, &elems) != TCL_OK) { - return TCL_ERROR; - } - if (len > 1 && Tcl_IsSafe(interp)) { - return TCL_ERROR; + goto failed; + } else if (len != 1) { + /* + * Note that at this point we know we can't issue any special + * instruction sequence as the mapping isn't one that we support at + * the compiled level. + */ + + goto cleanup; } targetCmdObj = elems[0]; + oldCmdPtr = cmdPtr; Tcl_IncrRefCount(targetCmdObj); - cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, targetCmdObj); + newCmdPtr = (Command *) Tcl_GetCommandFromObj(interp, targetCmdObj); TclDecrRefCount(targetCmdObj); - if (cmdPtr == NULL || cmdPtr->compileProc == NULL - || cmdPtr->nsPtr->flags & NS_SUPPRESS_COMPILATION - || cmdPtr->flags * CMD_HAS_EXEC_TRACES + if (newCmdPtr == NULL || Tcl_IsSafe(interp) + || newCmdPtr->nsPtr->flags & NS_SUPPRESS_COMPILATION + || newCmdPtr->flags & CMD_HAS_EXEC_TRACES || ((Interp *)interp)->flags & DONT_COMPILE_CMDS_INLINE) { /* * Maps to an undefined command or a command without a compiler. * Cannot compile. */ - return TCL_ERROR; + goto cleanup; + } + cmdPtr = newCmdPtr; + depth++; + + /* + * See whether we have a nested ensemble. If we do, we can go round the + * mulberry bush again, consuming the next word. + */ + + if (cmdPtr->compileProc == TclCompileEnsemble) { + tokenPtr = TokenAfter(tokenPtr); + ensemble = (Tcl_Command) cmdPtr; + goto checkNextWord; } /* * Now we've done the mapping process, can now actually try to compile. - * We do this by handing off to the subcommand's actual compiler. But to - * do that, we have to perform some trickery to rewrite the arguments. + * If there is a subcommand compiler and that successfully produces code, + * we'll use that. Otherwise, we fall back to generating opcodes to do the + * invoke at runtime. */ - TclParseInit(interp, NULL, 0, &synthetic); - synthetic.numWords = parsePtr->numWords - 2 + len; - TclGrowParseTokenArray(&synthetic, 2*len); - synthetic.numTokens = 2*len; + invokeAnyway = 1; + if (CompileToCompiledCommand(interp, parsePtr, depth, cmdPtr, + envPtr) == TCL_OK) { + ourResult = TCL_OK; + goto cleanup; + } /* - * Now we have the space to work in, install something rewritten. Note - * that we are here praying for all our might that none of these words are - * a script; the error detection code will crash if that happens and there - * is nothing we can do to avoid it! + * Failed to do a full compile for some reason. Try to do a direct invoke + * instead of going through the ensemble lookup process again. */ - for (i=0 ; i<len ; i++) { - int sclen; - const char *str = Tcl_GetStringFromObj(elems[i], &sclen); + failed: + if (depth < 250) { + if (depth > 1) { + if (!invokeAnyway) { + cmdPtr = oldCmdPtr; + depth--; + } + (void) Tcl_ListObjReplace(NULL, replaced, depth, 2, 0, NULL); + } + CompileToInvokedCommand(interp, parsePtr, replaced, cmdPtr, envPtr); + ourResult = TCL_OK; + } - synthetic.tokenPtr[2*i].type = TCL_TOKEN_SIMPLE_WORD; - synthetic.tokenPtr[2*i].start = str; - synthetic.tokenPtr[2*i].size = sclen; - synthetic.tokenPtr[2*i].numComponents = 1; + /* + * Release the memory we allocated. If we've got here, we've either done + * something useful or we're in a case that we can't compile at all and + * we're just giving up. + */ + + cleanup: + Tcl_DecrRefCount(replaced); + return ourResult; +} - synthetic.tokenPtr[2*i+1].type = TCL_TOKEN_TEXT; - synthetic.tokenPtr[2*i+1].start = str; - synthetic.tokenPtr[2*i+1].size = sclen; - synthetic.tokenPtr[2*i+1].numComponents = 0; +/* + * How to compile a subcommand using its own command compiler. To do that, we + * have to perform some trickery to rewrite the arguments, as compilers *must* + * have parse tokens that refer to addresses in the original script. + */ + +static int +CompileToCompiledCommand( + Tcl_Interp *interp, + Tcl_Parse *parsePtr, + int depth, + Command *cmdPtr, + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Parse synthetic; + Tcl_Token *tokenPtr; + int result, i; + int savedNumCmds = envPtr->numCommands; + int savedStackDepth = envPtr->currStackDepth; + unsigned savedCodeNext = envPtr->codeNext - envPtr->codeStart; + + if (cmdPtr->compileProc == NULL) { + return TCL_ERROR; + } + + TclParseInit(interp, NULL, 0, &synthetic); + synthetic.numWords = parsePtr->numWords - depth + 1; + TclGrowParseTokenArray(&synthetic, 2); + synthetic.numTokens = 2; + + /* + * Now we have the space to work in, install something rewritten. The + * first word will "officially" be the bytes of the structured ensemble + * name. That's technically wrong, but nobody will care; we just need + * *something* here... + */ + + synthetic.tokenPtr[0].type = TCL_TOKEN_SIMPLE_WORD; + synthetic.tokenPtr[0].start = parsePtr->tokenPtr[0].start; + synthetic.tokenPtr[0].numComponents = 1; + synthetic.tokenPtr[1].type = TCL_TOKEN_TEXT; + synthetic.tokenPtr[1].start = parsePtr->tokenPtr[0].start; + synthetic.tokenPtr[1].numComponents = 0; + for (i=0,tokenPtr=parsePtr->tokenPtr ; i<depth ; i++) { + int sclen = (tokenPtr->start - synthetic.tokenPtr[0].start) + + tokenPtr->size; + + synthetic.tokenPtr[0].size = sclen; + synthetic.tokenPtr[1].size = sclen; + tokenPtr = TokenAfter(tokenPtr); } /* * Copy over the real argument tokens. */ - for (i=len; i<synthetic.numWords; i++) { + for (i=1; i<synthetic.numWords; i++) { int toCopy; - tokenPtr = TokenAfter(tokenPtr); toCopy = tokenPtr->numComponents + 1; TclGrowParseTokenArray(&synthetic, toCopy); memcpy(synthetic.tokenPtr + synthetic.numTokens, tokenPtr, sizeof(Tcl_Token) * toCopy); synthetic.numTokens += toCopy; + tokenPtr = TokenAfter(tokenPtr); } /* @@ -2995,12 +3102,423 @@ TclCompileEnsemble( result = cmdPtr->compileProc(interp, &synthetic, cmdPtr, envPtr); /* + * If our target fails to compile, revert the number of commands and the + * pointer to the place to issue the next instruction. [Bug 3600328] + */ + + if (result != TCL_OK) { + envPtr->numCommands = savedNumCmds; + envPtr->currStackDepth = savedStackDepth; + envPtr->codeNext = envPtr->codeStart + savedCodeNext; + } + + /* * Clean up if necessary. */ Tcl_FreeParse(&synthetic); return result; } + +/* + * How to compile a subcommand to a _replacing_ invoke of its implementation + * command. + */ + +static void +CompileToInvokedCommand( + Tcl_Interp *interp, + Tcl_Parse *parsePtr, + Tcl_Obj *replacements, + Command *cmdPtr, + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Token *tokPtr; + Tcl_Obj *objPtr, **words; + char *bytes; + int length, i, numWords, cmdLit; + DefineLineInformation; + + /* + * Push the words of the command. Take care; the command words may be + * scripts that have backslashes in them, and [info frame 0] can see the + * difference. Hence the call to TclContinuationsEnterDerived... + */ + + Tcl_ListObjGetElements(NULL, replacements, &numWords, &words); + for (i=0,tokPtr=parsePtr->tokenPtr ; i<parsePtr->numWords ; i++) { + if (i > 0 && i < numWords+1) { + bytes = Tcl_GetStringFromObj(words[i-1], &length); + PushLiteral(envPtr, bytes, length); + } else if (tokPtr->type == TCL_TOKEN_SIMPLE_WORD) { + int literal = TclRegisterNewLiteral(envPtr, + tokPtr[1].start, tokPtr[1].size); + + if (envPtr->clNext) { + TclContinuationsEnterDerived( + envPtr->literalArrayPtr[literal].objPtr, + tokPtr[1].start - envPtr->source, + mapPtr->loc[eclIndex].next[i]); + } + TclEmitPush(literal, envPtr); + } else { + if (envPtr->clNext) { + SetLineInformation(i); + } + CompileTokens(envPtr, tokPtr, interp); + } + tokPtr = TokenAfter(tokPtr); + } + + /* + * Push the name of the command we're actually dispatching to as part of + * the implementation. + */ + + objPtr = Tcl_NewObj(); + Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr); + bytes = Tcl_GetStringFromObj(objPtr, &length); + cmdLit = TclRegisterNewCmdLiteral(envPtr, bytes, length); + TclSetCmdNameObj(interp, envPtr->literalArrayPtr[cmdLit].objPtr, cmdPtr); + TclEmitPush(cmdLit, envPtr); + TclDecrRefCount(objPtr); + + /* + * Do the replacing dispatch. + */ + + OP41( INVOKE_REPLACE, parsePtr->numWords, numWords+1); + TclAdjustStackDepth(-1, envPtr); /* Correction to stack depth calcs. */ +} + +/* + * Helpers that do issuing of instructions for commands that "don't have + * compilers" (well, they do; these). They all work by just generating base + * code to invoke the command; they're intended for ensemble subcommands so + * that the costs of INST_INVOKE_REPLACE can be avoided where we can work out + * that they're not needed. + * + * Note that these are NOT suitable for commands where there's an argument + * that is a script, as an [info level] or [info frame] in the inner context + * can see the difference. + */ + +static int +CompileBasicNArgCommand( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Token *tokenPtr; + Tcl_Obj *objPtr; + char *bytes; + int length, i, literal; + DefineLineInformation; + + /* + * Push the name of the command we're actually dispatching to as part of + * the implementation. + */ + + objPtr = Tcl_NewObj(); + Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr); + bytes = Tcl_GetStringFromObj(objPtr, &length); + literal = TclRegisterNewCmdLiteral(envPtr, bytes, length); + TclSetCmdNameObj(interp, envPtr->literalArrayPtr[literal].objPtr, cmdPtr); + TclEmitPush(literal, envPtr); + TclDecrRefCount(objPtr); + + /* + * Push the words of the command. + */ + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + for (i=1 ; i<parsePtr->numWords ; i++) { + if (envPtr->clNext) { + SetLineInformation(i); + } + if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + PushLiteral(envPtr, tokenPtr[1].start, tokenPtr[1].size); + } else { + CompileTokens(envPtr, tokenPtr, interp); + } + tokenPtr = TokenAfter(tokenPtr); + } + + /* + * Do the standard dispatch. + */ + + OP4( INVOKE_STK, i); + return TCL_OK; +} + +int +TclCompileBasic0ArgCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + /* + * Verify that the number of arguments is correct; that's the only case + * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, + * which is the only code that sees the shenanigans of ensemble dispatch. + */ + + if (parsePtr->numWords != 1) { + return TCL_ERROR; + } + + return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); +} + +int +TclCompileBasic1ArgCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + /* + * Verify that the number of arguments is correct; that's the only case + * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, + * which is the only code that sees the shenanigans of ensemble dispatch. + */ + + if (parsePtr->numWords != 2) { + return TCL_ERROR; + } + + return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); +} + +int +TclCompileBasic2ArgCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + /* + * Verify that the number of arguments is correct; that's the only case + * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, + * which is the only code that sees the shenanigans of ensemble dispatch. + */ + + if (parsePtr->numWords != 3) { + return TCL_ERROR; + } + + return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); +} + +int +TclCompileBasic3ArgCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + /* + * Verify that the number of arguments is correct; that's the only case + * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, + * which is the only code that sees the shenanigans of ensemble dispatch. + */ + + if (parsePtr->numWords != 4) { + return TCL_ERROR; + } + + return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); +} + +int +TclCompileBasic0Or1ArgCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + /* + * Verify that the number of arguments is correct; that's the only case + * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, + * which is the only code that sees the shenanigans of ensemble dispatch. + */ + + if (parsePtr->numWords != 1 && parsePtr->numWords != 2) { + return TCL_ERROR; + } + + return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); +} + +int +TclCompileBasic1Or2ArgCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + /* + * Verify that the number of arguments is correct; that's the only case + * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, + * which is the only code that sees the shenanigans of ensemble dispatch. + */ + + if (parsePtr->numWords != 2 && parsePtr->numWords != 3) { + return TCL_ERROR; + } + + return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); +} + +int +TclCompileBasic2Or3ArgCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + /* + * Verify that the number of arguments is correct; that's the only case + * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, + * which is the only code that sees the shenanigans of ensemble dispatch. + */ + + if (parsePtr->numWords != 3 && parsePtr->numWords != 4) { + return TCL_ERROR; + } + + return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); +} + +int +TclCompileBasic0To2ArgCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + /* + * Verify that the number of arguments is correct; that's the only case + * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, + * which is the only code that sees the shenanigans of ensemble dispatch. + */ + + if (parsePtr->numWords < 1 || parsePtr->numWords > 3) { + return TCL_ERROR; + } + + return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); +} + +int +TclCompileBasic1To3ArgCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + /* + * Verify that the number of arguments is correct; that's the only case + * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, + * which is the only code that sees the shenanigans of ensemble dispatch. + */ + + if (parsePtr->numWords < 2 || parsePtr->numWords > 4) { + return TCL_ERROR; + } + + return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); +} + +int +TclCompileBasicMin0ArgCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + /* + * Verify that the number of arguments is correct; that's the only case + * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, + * which is the only code that sees the shenanigans of ensemble dispatch. + */ + + if (parsePtr->numWords < 1) { + return TCL_ERROR; + } + + return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); +} + +int +TclCompileBasicMin1ArgCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + /* + * Verify that the number of arguments is correct; that's the only case + * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, + * which is the only code that sees the shenanigans of ensemble dispatch. + */ + + if (parsePtr->numWords < 2) { + return TCL_ERROR; + } + + return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); +} + +int +TclCompileBasicMin2ArgCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + /* + * Verify that the number of arguments is correct; that's the only case + * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time, + * which is the only code that sees the shenanigans of ensemble dispatch. + */ + + if (parsePtr->numWords < 3) { + return TCL_ERROR; + } + + return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr); +} /* * Local Variables: diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 3e6e094..d3bae38 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -194,13 +194,27 @@ VarHashCreateVar( * 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 + * We use the new compile-time assertions to check that nCleanup is constant * and within range. */ -#define NEXT_INST_F(pcAdjustment, nCleanup, resultHandling) \ +/* Verify the stack depth, only when no expansion is in progress */ + +#if TCL_COMPILE_DEBUG +#define CHECK_STACK() \ + do { \ + ValidatePcAndStackTop(codePtr, pc, CURR_DEPTH, \ + /*checkStack*/ !(starting || auxObjList)); \ + starting = 0; \ + } while (0) +#else +#define CHECK_STACK() +#endif + +#define NEXT_INST_F(pcAdjustment, nCleanup, resultHandling) \ do { \ TCL_CT_ASSERT((nCleanup >= 0) && (nCleanup <= 2)); \ + CHECK_STACK(); \ if (nCleanup == 0) { \ if (resultHandling != 0) { \ if ((resultHandling) > 0) { \ @@ -229,7 +243,8 @@ VarHashCreateVar( } \ } while (0) -#define NEXT_INST_V(pcAdjustment, nCleanup, resultHandling) \ +#define NEXT_INST_V(pcAdjustment, nCleanup, resultHandling) \ + CHECK_STACK(); \ do { \ pc += (pcAdjustment); \ cleanup = (nCleanup); \ @@ -633,7 +648,7 @@ static void PrintByteCodeInfo(ByteCode *codePtr); static const char * StringForResultCode(int result); static void ValidatePcAndStackTop(ByteCode *codePtr, const unsigned char *pc, int stackTop, - int stackLowerBound, int checkStack); + int checkStack); #endif /* TCL_COMPILE_DEBUG */ static ByteCode * CompileExprObj(Tcl_Interp *interp, Tcl_Obj *objPtr); static void DeleteExecStack(ExecStack *esPtr); @@ -995,6 +1010,7 @@ GrowEvaluationStack( return MEMSTART(markerPtr); } } else { +#ifndef PURIFY Tcl_Obj **tmpMarkerPtr = esPtr->tosPtr + 1; int offset = OFFSET(tmpMarkerPtr); @@ -1011,6 +1027,7 @@ GrowEvaluationStack( *esPtr->markerPtr = (Tcl_Obj *) markerPtr; return memStart; } +#endif } /* @@ -1024,6 +1041,7 @@ GrowEvaluationStack( } needed = growth + moveWords + WALLOCALIGN; + /* * Check if there is enough room in the next stack (if there is one, it * should be both empty and the last one!) @@ -1053,10 +1071,15 @@ GrowEvaluationStack( * including the elements to be copied over and the new marker. */ +#ifndef PURIFY newElems = 2*currElems; while (needed > newElems) { newElems *= 2; } +#else + newElems = needed; +#endif + newBytes = sizeof(ExecStack) + (newElems-1) * sizeof(Tcl_Obj *); oldPtr = esPtr; @@ -1159,7 +1182,7 @@ TclStackFree( Tcl_Obj **markerPtr, *marker; if (iPtr == NULL || iPtr->execEnvPtr == NULL) { - Tcl_Free((char *) freePtr); + ckfree((char *) freePtr); return; } @@ -1205,6 +1228,10 @@ TclStackFree( } if (esPtr->prevPtr) { eePtr->execStackPtr = esPtr->prevPtr; +#ifdef PURIFY + eePtr->execStackPtr->nextPtr = NULL; + DeleteExecStack(esPtr); +#endif } else { eePtr->execStackPtr = esPtr; } @@ -1219,7 +1246,7 @@ TclStackAlloc( int numWords = (numBytes + (sizeof(Tcl_Obj *) - 1))/sizeof(Tcl_Obj *); if (iPtr == NULL || iPtr->execEnvPtr == NULL) { - return (void *) Tcl_Alloc(numBytes); + return (void *) ckalloc(numBytes); } return (void *) StackAllocWords(interp, numWords); @@ -1238,7 +1265,7 @@ TclStackRealloc( int numWords; if (iPtr == NULL || iPtr->execEnvPtr == NULL) { - return (void *) Tcl_Realloc((char *) ptr, numBytes); + return (void *) ckrealloc((char *) ptr, numBytes); } eePtr = iPtr->execEnvPtr; @@ -2015,7 +2042,8 @@ ExecuteByteCode( Tcl_Obj **tosPtr; /* Cached pointer to top of evaluation * stack. */ const unsigned char *pc; /* The current program counter. */ - + unsigned char inst; /* The currently running instruction */ + /* * Transfer variables - needed only between opcodes, but not while * executing an instruction. @@ -2040,6 +2068,7 @@ ExecuteByteCode( #endif #ifdef TCL_COMPILE_DEBUG + int starting = 1; traceInstructions = (tclTraceExec == 3); #endif @@ -2176,24 +2205,6 @@ ExecuteByteCode( } cleanup0: -#ifdef TCL_COMPILE_DEBUG - /* - * Skip the stack depth check if an expansion is in progress. - */ - - ValidatePcAndStackTop(codePtr, pc, CURR_DEPTH, 0, - /*checkStack*/ auxObjList == NULL); - if (traceInstructions) { - fprintf(stdout, "%2d: %2d ", iPtr->numLevels, (int) CURR_DEPTH); - TclPrintInstruction(codePtr, pc); - fflush(stdout); - } -#endif /* TCL_COMPILE_DEBUG */ - -#ifdef TCL_COMPILE_STATS - iPtr->stats.instructionCount[*pc]++; -#endif - /* * Check for asynchronous handlers [Bug 746722]; we do the check every * ASYNC_CHECK_COUNT_MASK instruction, of the form (2**n-1). @@ -2225,8 +2236,6 @@ ExecuteByteCode( CACHE_STACK_INFO(); } - TCL_DTRACE_INST_NEXT(); - /* * These two instructions account for 26% of all instructions (according * to measurements on tclbench by Ben Vitale @@ -2236,13 +2245,53 @@ ExecuteByteCode( * reduces total obj size. */ - if (*pc == INST_LOAD_SCALAR) { - goto instLoadScalar; - } else if (*pc == INST_PUSH) { - goto instPushPeephole; + inst = *pc; + + peepholeStart: +#ifdef TCL_COMPILE_STATS + iPtr->stats.instructionCount[*pc]++; +#endif + +#ifdef TCL_COMPILE_DEBUG + /* + * Skip the stack depth check if an expansion is in progress. + */ + + CHECK_STACK(); + if (traceInstructions) { + fprintf(stdout, "%2d: %2d ", iPtr->numLevels, (int) CURR_DEPTH); + TclPrintInstruction(codePtr, pc); + fflush(stdout); } +#endif /* TCL_COMPILE_DEBUG */ - switch (*pc) { + TCL_DTRACE_INST_NEXT(); + + if (inst == INST_LOAD_SCALAR) { + goto instLoadScalar; + } else if (inst == INST_PUSH) { + PUSH_OBJECT(codePtr->objArrayPtr[TclGetUInt4AtPtr(pc+1)]); + TRACE_WITH_OBJ(("%u => ", TclGetInt4AtPtr(pc+1)), OBJ_AT_TOS); + inst = *(pc += 5); + goto peepholeStart; + } else if (inst == INST_START_CMD) { + /* + * Peephole: do not run INST_START_CMD, just skip it + */ + + iPtr->cmdCount += TclGetUInt4AtPtr(pc+5); + if (checkInterp) { + checkInterp = 0; + if ((codePtr->compileEpoch != iPtr->compileEpoch) + || (codePtr->nsEpoch != iPtr->varFramePtr->nsPtr->resolverEpoch)) { + goto instStartCmdFailed; + } + } + inst = *(pc += 9); + goto peepholeStart; + } + + switch (inst) { case INST_SYNTAX: case INST_RETURN_IMM: { int code = TclGetInt4AtPtr(pc+1); @@ -2294,6 +2343,7 @@ ExecuteByteCode( NULL); goto gotError; } + NRE_ASSERT(!COR_IS_SUSPENDED(corPtr)); #ifdef TCL_COMPILE_DEBUG TRACE_WITH_OBJ(("yield, result="), iPtr->objResultPtr); @@ -2326,7 +2376,6 @@ ExecuteByteCode( case INST_TAILCALL: { Tcl_Obj *listPtr, *nsObjPtr; - NRE_callback *tailcallPtr; opnd = TclGetUInt1AtPtr(pc+1); @@ -2360,18 +2409,12 @@ ExecuteByteCode( listPtr = Tcl_NewListObj(opnd, &OBJ_AT_DEPTH(opnd-1)); nsObjPtr = Tcl_NewStringObj(iPtr->varFramePtr->nsPtr->fullName, -1); - Tcl_IncrRefCount(listPtr); - Tcl_IncrRefCount(nsObjPtr); - TclNRAddCallback(interp, TclNRTailcallEval, listPtr, nsObjPtr, - NULL, NULL); - - /* - * Unstitch ourselves and do a [return]. - */ + TclListObjSetElement(interp, listPtr, 0, nsObjPtr); + if (iPtr->varFramePtr->tailcallPtr) { + Tcl_DecrRefCount(iPtr->varFramePtr->tailcallPtr); + } + iPtr->varFramePtr->tailcallPtr = listPtr; - tailcallPtr = TOP_CB(interp); - TOP_CB(interp) = tailcallPtr->nextPtr; - iPtr->varFramePtr->tailcallPtr = tailcallPtr; result = TCL_RETURN; cleanup = opnd; goto processExceptionReturn; @@ -2399,88 +2442,13 @@ ExecuteByteCode( (void) POP_OBJECT(); goto abnormalReturn; - case INST_PUSH: - instPushPeephole: - PUSH_OBJECT(codePtr->objArrayPtr[TclGetUInt4AtPtr(pc+1)]); - TRACE_WITH_OBJ(("%u => ", TclGetInt4AtPtr(pc+1)), OBJ_AT_TOS); - pc += 5; -#if !TCL_COMPILE_DEBUG - /* - * Runtime peephole optimisation: check if we are pushing again. - */ - - if (*pc == INST_PUSH) { - TCL_DTRACE_INST_NEXT(); - goto instPushPeephole; - } -#endif - NEXT_INST_F(0, 0, 0); - case INST_POP: TRACE_WITH_OBJ(("=> discarding "), OBJ_AT_TOS); POP_DROP_OBJECT(); - - /* - * Runtime peephole optimisation: an INST_POP is scheduled at the end - * of most commands. If the next instruction is an INST_START_CMD, - * fall through to it. - */ - - pc++; -#if !TCL_COMPILE_DEBUG - if (*pc == INST_START_CMD) { - TCL_DTRACE_INST_NEXT(); - goto instStartCmdPeephole; - } -#endif - NEXT_INST_F(0, 0, 0); - - case INST_START_CMD: -#if !TCL_COMPILE_DEBUG - instStartCmdPeephole: -#endif - /* - * Remark that if the interpreter is marked for deletion its - * compileEpoch is modified, so that the epoch check also verifies - * that the interp is not deleted. If no outside call has been made - * since the last check, it is safe to omit the check. - */ - - iPtr->cmdCount += TclGetUInt4AtPtr(pc+5); - if (!checkInterp) { - goto instStartCmdOK; - } else if (((codePtr->compileEpoch == iPtr->compileEpoch) - && (codePtr->nsEpoch == iPtr->varFramePtr->nsPtr->resolverEpoch)) - || (codePtr->flags & TCL_BYTECODE_PRECOMPILED)) { - checkInterp = 0; - instStartCmdOK: - NEXT_INST_F(9, 0, 0); - } else { - const char *bytes; - - length = 0; - - /* - * We used to switch to direct eval; for NRE-awareness we now - * compile and eval the command so that this evaluation does not - * add a new TEBC instance. [Bug 2910748] - */ - - if (TclInterpReady(interp) == TCL_ERROR) { - goto gotError; - } - - codePtr->flags |= TCL_BYTECODE_RECOMPILE; - bytes = GetSrcInfoForPc(pc, codePtr, &length, NULL); - opnd = TclGetUInt4AtPtr(pc+1); - pc += (opnd-1); - PUSH_OBJECT(Tcl_NewStringObj(bytes, length)); - goto instEvalStk; - } + NEXT_INST_F(1, 0, 0); case INST_NOP: - pc += 1; - goto cleanup0; + NEXT_INST_F(1, 0, 0); case INST_DUP: objResultPtr = OBJ_AT_TOS; @@ -2840,6 +2808,70 @@ ExecuteByteCode( return TclNREvalObjv(interp, objc, objv, TCL_EVAL_NOERR, NULL); + case INST_INVOKE_REPLACE: + objc = TclGetUInt4AtPtr(pc+1); + opnd = TclGetUInt1AtPtr(pc+5); + objPtr = POP_OBJECT(); + objv = &OBJ_AT_DEPTH(objc-1); + cleanup = objc; +#ifdef TCL_COMPILE_DEBUG + if (tclTraceExec >= 2) { + int i; + + if (traceInstructions) { + strncpy(cmdNameBuf, TclGetString(objv[0]), 20); + TRACE(("%u => call (implementation %s) ", objc, O2S(objPtr))); + } else { + fprintf(stdout, + "%d: (%u) invoking (using implementation %s) ", + iPtr->numLevels, (unsigned)(pc - codePtr->codeStart), + O2S(objPtr)); + } + for (i = 0; i < objc; i++) { + if (i < opnd) { + fprintf(stdout, "<"); + TclPrintObject(stdout, objv[i], 15); + fprintf(stdout, ">"); + } else { + TclPrintObject(stdout, objv[i], 15); + } + fprintf(stdout, " "); + } + fprintf(stdout, "\n"); + fflush(stdout); + } +#endif /*TCL_COMPILE_DEBUG*/ + { + Tcl_Obj *copyPtr = Tcl_NewListObj(objc - opnd + 1, NULL); + register List *listRepPtr = copyPtr->internalRep.twoPtrValue.ptr1; + Tcl_Obj **copyObjv = &listRepPtr->elements; + int i; + + listRepPtr->elemCount = objc - opnd + 1; + copyObjv[0] = objPtr; + memcpy(copyObjv+1, objv+opnd, sizeof(Tcl_Obj *) * (objc - opnd)); + for (i=1 ; i<objc-opnd+1 ; i++) { + Tcl_IncrRefCount(copyObjv[i]); + } + objPtr = copyPtr; + } + bcFramePtr->data.tebc.pc = (char *) pc; + iPtr->cmdFramePtr = bcFramePtr; + if (iPtr->flags & INTERP_DEBUG_FRAME) { + TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc, + codePtr, bcFramePtr, pc - codePtr->codeStart); + } + iPtr->ensembleRewrite.sourceObjs = objv; + iPtr->ensembleRewrite.numRemovedObjs = opnd; + iPtr->ensembleRewrite.numInsertedObjs = 1; + DECACHE_STACK_INFO(); + pc += 6; + TEBC_YIELD(); + + TclNRAddCallback(interp, TclClearRootEnsemble, NULL,NULL,NULL,NULL); + TclSkipTailcall(interp); + return TclNREvalObjEx(interp, objPtr, TCL_EVAL_INVOKE, NULL, INT_MIN); + /* * ----------------------------------------------------------------- * Start of INST_LOAD instructions. @@ -3201,8 +3233,8 @@ ExecuteByteCode( varPtr = TclObjLookupVarEx(interp, objPtr, part2Ptr, TCL_LEAVE_ERR_MSG, "read", 1, 1, &arrayPtr); if (!varPtr) { - Tcl_AddObjErrorInfo(interp, - "\n (reading value of variable to increment)", -1); + Tcl_AddErrorInfo(interp, + "\n (reading value of variable to increment)"); TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); Tcl_DecrRefCount(incrPtr); goto gotError; @@ -6658,6 +6690,42 @@ ExecuteByteCode( TclStackFree(interp, TD); /* free my stack */ return result; + + /* + * INST_START_CMD failure case removed where it doesn't bother that much + * + * 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. + + * case INST_START_CMD: + */ + + instStartCmdFailed: + { + const char *bytes; + + checkInterp = 1; + length = 0; + + /* + * We used to switch to direct eval; for NRE-awareness we now compile + * and eval the command so that this evaluation does not add a new + * TEBC instance. [Bug 2910748] + */ + + if (TclInterpReady(interp) == TCL_ERROR) { + goto gotError; + } + + codePtr->flags |= TCL_BYTECODE_RECOMPILE; + bytes = GetSrcInfoForPc(pc, codePtr, &length, NULL); + opnd = TclGetUInt4AtPtr(pc+1); + pc += (opnd-1); + PUSH_OBJECT(Tcl_NewStringObj(bytes, length)); + goto instEvalStk; + } } #undef codePtr @@ -8121,11 +8189,10 @@ ValidatePcAndStackTop( int stackTop, /* Current stack top. Must be between * stackLowerBound and stackUpperBound * (inclusive). */ - int stackLowerBound, /* Smallest legal value for stackTop. */ int checkStack) /* 0 if the stack depth check should be * skipped. */ { - int stackUpperBound = stackLowerBound + codePtr->maxStackDepth; + int stackUpperBound = codePtr->maxStackDepth; /* Greatest legal value for stackTop. */ unsigned relativePc = (unsigned) (pc - codePtr->codeStart); unsigned long codeStart = (unsigned long) codePtr->codeStart; @@ -8143,13 +8210,13 @@ ValidatePcAndStackTop( (unsigned) opCode, relativePc); Tcl_Panic("TclNRExecuteByteCode execution failure: bad opcode"); } - if (checkStack && - ((stackTop < stackLowerBound) || (stackTop > stackUpperBound))) { + if (checkStack && + ((stackTop < 0) || (stackTop > stackUpperBound))) { int numChars; const char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars, NULL); - fprintf(stderr, "\nBad stack top %d at pc %u in TclNRExecuteByteCode (min %i, max %i)", - stackTop, relativePc, stackLowerBound, stackUpperBound); + fprintf(stderr, "\nBad stack top %d at pc %u in TclNRExecuteByteCode (min 0, max %i)", + stackTop, relativePc, stackUpperBound); if (cmd != NULL) { Tcl_Obj *message; diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index 33c1496..adf60d9 100644 --- a/generic/tclFCmd.c +++ b/generic/tclFCmd.c @@ -10,6 +10,7 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ +#include <sys/stat.h> #include "tclInt.h" #include "tclFileSystem.h" diff --git a/generic/tclFileName.c b/generic/tclFileName.c index a519f0e..f362239 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -11,6 +11,7 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ +#include <sys/stat.h> #include "tclInt.h" #include "tclRegexp.h" #include "tclFileSystem.h" /* For TclGetPathType() */ diff --git a/generic/tclIO.c b/generic/tclIO.c index 5bd0e2a..0568d77 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -2472,7 +2472,7 @@ FlushChannel( * it's a tty channel (dup'ed underneath) */ - if (!GotFlag(statePtr, BG_FLUSH_SCHEDULED)) { + if (!GotFlag(statePtr, BG_FLUSH_SCHEDULED) && !TclInExit()) { SetFlag(statePtr, BG_FLUSH_SCHEDULED); UpdateInterest(chanPtr); } diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index 2b3e805..4ade3a9 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -1939,25 +1939,25 @@ TclInitChanCmd( * function at the moment. */ static const EnsembleImplMap initMap[] = { - {"blocked", Tcl_FblockedObjCmd, NULL, NULL, NULL, 0}, - {"close", Tcl_CloseObjCmd, NULL, NULL, NULL, 0}, - {"copy", Tcl_FcopyObjCmd, NULL, NULL, NULL, 0}, - {"create", TclChanCreateObjCmd, NULL, NULL, NULL, 0}, /* TIP #219 */ - {"eof", Tcl_EofObjCmd, NULL, NULL, NULL, 0}, - {"event", Tcl_FileEventObjCmd, NULL, NULL, NULL, 0}, - {"flush", Tcl_FlushObjCmd, NULL, NULL, NULL, 0}, - {"gets", Tcl_GetsObjCmd, NULL, NULL, NULL, 0}, - {"names", TclChannelNamesCmd, NULL, NULL, NULL, 0}, - {"pending", ChanPendingObjCmd, NULL, NULL, NULL, 0}, /* TIP #287 */ - {"pop", TclChanPopObjCmd, NULL, NULL, NULL, 0}, /* TIP #230 */ - {"postevent", TclChanPostEventObjCmd, NULL, NULL, NULL, 0}, /* TIP #219 */ - {"push", TclChanPushObjCmd, NULL, NULL, NULL, 0}, /* TIP #230 */ - {"puts", Tcl_PutsObjCmd, NULL, NULL, NULL, 0}, - {"read", Tcl_ReadObjCmd, NULL, NULL, NULL, 0}, - {"seek", Tcl_SeekObjCmd, NULL, NULL, NULL, 0}, - {"pipe", ChanPipeObjCmd, NULL, NULL, NULL, 0}, /* TIP #304 */ - {"tell", Tcl_TellObjCmd, NULL, NULL, NULL, 0}, - {"truncate", ChanTruncateObjCmd, NULL, NULL, NULL, 0}, /* TIP #208 */ + {"blocked", Tcl_FblockedObjCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"close", Tcl_CloseObjCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, + {"copy", Tcl_FcopyObjCmd, NULL, NULL, NULL, 0}, + {"create", TclChanCreateObjCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, /* TIP #219 */ + {"eof", Tcl_EofObjCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"event", Tcl_FileEventObjCmd, TclCompileBasic2Or3ArgCmd, NULL, NULL, 0}, + {"flush", Tcl_FlushObjCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"gets", Tcl_GetsObjCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, + {"names", TclChannelNamesCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, + {"pending", ChanPendingObjCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, /* TIP #287 */ + {"pipe", ChanPipeObjCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, /* TIP #304 */ + {"pop", TclChanPopObjCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, /* TIP #230 */ + {"postevent", TclChanPostEventObjCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, /* TIP #219 */ + {"push", TclChanPushObjCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, /* TIP #230 */ + {"puts", Tcl_PutsObjCmd, NULL, NULL, NULL, 0}, + {"read", Tcl_ReadObjCmd, NULL, NULL, NULL, 0}, + {"seek", Tcl_SeekObjCmd, TclCompileBasic2Or3ArgCmd, NULL, NULL, 0}, + {"tell", Tcl_TellObjCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"truncate", ChanTruncateObjCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, /* TIP #208 */ {NULL, NULL, NULL, NULL, NULL, 0} }; static const char *const extras[] = { diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c index 2b9efb9..1de635f 100644 --- a/generic/tclIORTrans.c +++ b/generic/tclIORTrans.c @@ -2942,7 +2942,7 @@ ResultClear( return; } - Tcl_Free((char *) rPtr->buf); + ckfree((char *) rPtr->buf); rPtr->buf = NULL; rPtr->allocated = 0; } @@ -2977,10 +2977,10 @@ ResultAdd( if (rPtr->allocated == 0) { rPtr->allocated = toWrite + RB_INCREMENT; - rPtr->buf = UCHARP(Tcl_Alloc(rPtr->allocated)); + rPtr->buf = UCHARP(ckalloc(rPtr->allocated)); } else { rPtr->allocated += toWrite + RB_INCREMENT; - rPtr->buf = UCHARP(Tcl_Realloc((char *) rPtr->buf, + rPtr->buf = UCHARP(ckrealloc((char *) rPtr->buf, rPtr->allocated)); } } diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 8773cb6..6541c3d 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -18,9 +18,7 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -#if defined(HAVE_SYS_STAT_H) && !defined _WIN32 -# include <sys/stat.h> -#endif +#include <sys/stat.h> #include "tclInt.h" #ifdef __WIN32__ # include "tclWinInt.h" diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index cb345e2..0372668 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -69,12 +69,12 @@ typedef struct { * The following macros greatly simplify moving through a table... */ -#define STRING_AT(table, offset, index) \ - (*((const char *const *)(((char *)(table)) + ((offset) * (index))))) +#define STRING_AT(table, offset) \ + (*((const char *const *)(((char *)(table)) + (offset)))) #define NEXT_ENTRY(table, offset) \ - (&(STRING_AT(table, offset, 1))) + (&(STRING_AT(table, offset))) #define EXPAND_OF(indexRep) \ - STRING_AT((indexRep)->tablePtr, (indexRep)->offset, (indexRep)->index) + STRING_AT((indexRep)->tablePtr, (indexRep)->offset*(indexRep)->index) /* *---------------------------------------------------------------------- @@ -238,7 +238,7 @@ GetIndexFromObjList( * a proper match, then TCL_ERROR is returned and an error message is * left in interp's result (unless interp is NULL). The msg argument is * used in the error message; for example, if msg has the value "option" - * then the error message will say something flag 'bad option "foo": must + * then the error message will say something like 'bad option "foo": must * be ...' * * Side effects: @@ -270,6 +270,10 @@ Tcl_GetIndexFromObjStruct( Tcl_Obj *resultPtr; IndexRep *indexRep; + /* Protect against invalid values, like -1 or 0. */ + if (offset < (int)sizeof(char *)) { + offset = (int)sizeof(char *); + } /* * See if there is a valid cached result from a previous lookup. */ @@ -533,9 +537,9 @@ TclInitPrefixCmd( Tcl_Interp *interp) /* Current interpreter. */ { static const EnsembleImplMap prefixImplMap[] = { - {"all", PrefixAllObjCmd, NULL, NULL, NULL, 0}, - {"longest", PrefixLongestObjCmd, NULL, NULL, NULL, 0}, - {"match", PrefixMatchObjCmd, NULL, NULL, NULL, 0}, + {"all", PrefixAllObjCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, + {"longest", PrefixLongestObjCmd,TclCompileBasic2ArgCmd, NULL, NULL, 0}, + {"match", PrefixMatchObjCmd, TclCompileBasicMin2ArgCmd, NULL, NULL, 0}, {NULL, NULL, NULL, NULL, NULL, 0} }; Tcl_Command prefixCmd; diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 7b77579..edb3046 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -629,14 +629,14 @@ declare 156 { declare 157 { Var *TclVarTraceExists(Tcl_Interp *interp, const char *varName) } -# REMOVED - use public Tcl_SetStartupScript() -#declare 158 { -# void TclSetStartupScriptFileName(const char *filename) -#} -# REMOVED - use public Tcl_GetStartupScript() -#declare 159 { -# const char *TclGetStartupScriptFileName(void) -#} +# REMOVED (except from stub table) - use public Tcl_SetStartupScript() +declare 158 { + void TclSetStartupScriptFileName(const char *filename) +} +# REMOVED (except from stub table) - use public Tcl_GetStartupScript() +declare 159 { + const char *TclGetStartupScriptFileName(void) +} #declare 160 { # int TclpMatchFilesTypes(Tcl_Interp *interp, char *separators, # Tcl_DString *dirPtr, char *pattern, char *tail, @@ -681,14 +681,14 @@ declare 166 { } # VFS-aware versions of Tcl*StartupScriptFileName (158 and 159 above) -# REMOVED - use public Tcl_SetStartupScript() -#declare 167 { -# void TclSetStartupScriptPath(Tcl_Obj *pathPtr) -#} -# REMOVED - use public Tcl_GetStartupScript() -#declare 168 { -# Tcl_Obj *TclGetStartupScriptPath(void) -#} +# REMOVED (except from stub table) - use public Tcl_SetStartupScript() +declare 167 { + void TclSetStartupScriptPath(Tcl_Obj *pathPtr) +} +# REMOVED (except from stub table) - use public Tcl_GetStartupScript() +declare 168 { + Tcl_Obj *TclGetStartupScriptPath(void) +} # variant of Tcl_UtfNCmp that takes n as bytes, not chars declare 169 { int TclpUtfNcmp2(const char *s1, const char *s2, unsigned long n) @@ -734,13 +734,13 @@ declare 177 { void TclVarErrMsg(Tcl_Interp *interp, const char *part1, const char *part2, const char *operation, const char *reason) } -# TIP 338 made these public - now declared in tcl.h -#declare 178 { -# void Tcl_SetStartupScript(Tcl_Obj *pathPtr, const char *encodingName) -#} -#declare 179 { -# Tcl_Obj *Tcl_GetStartupScript(const char **encodingNamePtr) -#} +# TIP 338 made these public - now declared in tcl.h too +declare 178 { + void Tcl_SetStartupScript(Tcl_Obj *pathPtr, const char *encodingName) +} +declare 179 { + Tcl_Obj *Tcl_GetStartupScript(const char **encodingNamePtr) +} # REMOVED # Allocate lists without copying arrays @@ -1152,9 +1152,6 @@ declare 27 win { declare 28 win { void TclWinResetInterfaces(void) } -declare 29 win { - int TclWinCPUID(unsigned int index, unsigned int *regs) -} ################################ # Unix specific functions @@ -1222,12 +1219,6 @@ declare 14 unix { const Tcl_StatBuf *statBufPtr, int dontCopyAtts) } -# Added in 8.6; core of TclpOpenTemporaryFile -declare 20 unix { - int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, Tcl_Obj *basenameObj, - Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj) -} - ################################ # Mac OS X specific functions @@ -1251,9 +1242,17 @@ declare 18 macosx { declare 19 macosx { void TclMacOSXNotifierAddRunLoopMode(const void *runLoopMode) } -declare 29 unix { + +declare 29 {win unix} { int TclWinCPUID(unsigned int index, unsigned int *regs) } +# Added in 8.6; core of TclpOpenTemporaryFile +declare 30 {win unix} { + int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, Tcl_Obj *basenameObj, + Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj) +} + + # Local Variables: # mode: tcl diff --git a/generic/tclInt.h b/generic/tclInt.h index f4691b8..cbfc105 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1154,7 +1154,7 @@ typedef struct CallFrame { * meaning of the value is, which we do not * specify. */ LocalCache *localCachePtr; - struct NRE_callback *tailcallPtr; + Tcl_Obj *tailcallPtr; /* NULL if no tailcall is scheduled */ } CallFrame; @@ -2224,7 +2224,6 @@ typedef struct InterpList { #define TCL_ALLOW_EXCEPTIONS 4 #define TCL_EVAL_FILE 2 #define TCL_EVAL_CTX 8 -#define TCL_EVAL_REDIRECT 16 /* * Flag bits for Interp structures: @@ -2769,8 +2768,12 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldmObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldToObjCmd; -MODULE_SCOPE void TclSpliceTailcall(Tcl_Interp *interp, - struct NRE_callback *tailcallPtr); +MODULE_SCOPE void TclSetTailcall(Tcl_Interp *interp, Tcl_Obj *tailcallPtr); +MODULE_SCOPE void TclPushTailcallPoint(Tcl_Interp *interp); + +/* These two can be considered for the public api */ +MODULE_SCOPE void TclMarkTailcall(Tcl_Interp *interp); +MODULE_SCOPE void TclSkipTailcall(Tcl_Interp *interp); /* * This structure holds the data for the various iteration callbacks used to @@ -2845,7 +2848,6 @@ MODULE_SCOPE void TclAppendBytesToByteArray(Tcl_Obj *objPtr, const unsigned char *bytes, int len); MODULE_SCOPE int TclNREvalCmd(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); -MODULE_SCOPE void TclPushTailcallPoint(Tcl_Interp *interp); MODULE_SCOPE void TclAdvanceContinuations(int *line, int **next, int loc); MODULE_SCOPE void TclAdvanceLines(int *line, const char *start, @@ -3672,6 +3674,42 @@ MODULE_SCOPE int TclCompileWhileCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileYieldCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileBasic0ArgCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileBasic1ArgCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileBasic2ArgCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileBasic3ArgCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileBasic0Or1ArgCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileBasic1Or2ArgCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileBasic2Or3ArgCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileBasic0To2ArgCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileBasic1To3ArgCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileBasicMin0ArgCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileBasicMin1ArgCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileBasicMin2ArgCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclInvertOpCmd(ClientData clientData, Tcl_Interp *interp, int objc, @@ -3964,12 +4002,13 @@ typedef const char *TclDTraceStr; */ # define TclAllocObjStorageEx(interp, objPtr) \ - (objPtr) = (Tcl_Obj *) Tcl_Alloc(sizeof(Tcl_Obj)) + (objPtr) = (Tcl_Obj *) ckalloc(sizeof(Tcl_Obj)) # define TclFreeObjStorageEx(interp, objPtr) \ ckfree((char *) (objPtr)) #undef USE_THREAD_ALLOC +#undef USE_TCLALLOC #elif defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) /* @@ -4745,35 +4784,6 @@ typedef struct NRE_callback { TOP_CB(interp) = callbackPtr; \ } while (0) -#define TclNRDeferCallback(interp,postProcPtr,data0,data1,data2,data3) \ - do { \ - NRE_callback *callbackPtr; \ - TCLNR_ALLOC((interp), (callbackPtr)); \ - callbackPtr->procPtr = (postProcPtr); \ - callbackPtr->data[0] = (ClientData)(data0); \ - callbackPtr->data[1] = (ClientData)(data1); \ - callbackPtr->data[2] = (ClientData)(data2); \ - callbackPtr->data[3] = (ClientData)(data3); \ - callbackPtr->nextPtr = ((Interp *)interp)->deferredCallbacks; \ - ((Interp *)interp)->deferredCallbacks = callbackPtr; \ - } while (0) - -#define TclNRSpliceCallbacks(interp, topPtr) \ - do { \ - NRE_callback *bottomPtr = topPtr; \ - while (bottomPtr->nextPtr) { \ - bottomPtr = bottomPtr->nextPtr; \ - } \ - bottomPtr->nextPtr = TOP_CB(interp); \ - TOP_CB(interp) = topPtr; \ - } while (0) - -#define TclNRSpliceDeferred(interp) \ - if (((Interp *)interp)->deferredCallbacks) { \ - TclNRSpliceCallbacks(interp, ((Interp *)interp)->deferredCallbacks); \ - ((Interp *)interp)->deferredCallbacks = NULL; \ - } - #if NRE_USE_SMALL_ALLOC #define TCLNR_ALLOC(interp, ptr) \ TclSmallAllocEx(interp, sizeof(NRE_callback), (ptr)) diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 65b1888..d1615e0 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -18,19 +18,20 @@ #include "tclPort.h" /* [Bug #803489] Tcl_FindNamespace problem in the Stubs table */ -#undef Tcl_AppendExportList #undef Tcl_CreateNamespace #undef Tcl_DeleteNamespace +#undef Tcl_AppendExportList #undef Tcl_Export -#undef Tcl_FindCommand -#undef Tcl_FindNamespace -#undef Tcl_FindNamespaceVar +#undef Tcl_Import #undef Tcl_ForgetImport -#undef Tcl_GetCommandFromObj -#undef Tcl_GetCommandFullName #undef Tcl_GetCurrentNamespace #undef Tcl_GetGlobalNamespace -#undef Tcl_Import +#undef Tcl_FindNamespace +#undef Tcl_FindCommand +#undef Tcl_GetCommandFromObj +#undef Tcl_GetCommandFullName +#undef Tcl_SetStartupScript +#undef Tcl_GetStartupScript /* * WARNING: This file is automatically generated by the tools/genStubs.tcl @@ -376,8 +377,10 @@ TCLAPI void TclRegError(Tcl_Interp *interp, const char *msg, /* 157 */ TCLAPI Var * TclVarTraceExists(Tcl_Interp *interp, const char *varName); -/* Slot 158 is reserved */ -/* Slot 159 is reserved */ +/* 158 */ +TCLAPI void TclSetStartupScriptFileName(const char *filename); +/* 159 */ +TCLAPI const char * TclGetStartupScriptFileName(void); /* Slot 160 is reserved */ /* 161 */ TCLAPI int TclChannelTransform(Tcl_Interp *interp, @@ -395,8 +398,10 @@ TCLAPI void TclpSetInitialEncodings(void); TCLAPI int TclListObjSetElement(Tcl_Interp *interp, Tcl_Obj *listPtr, int index, Tcl_Obj *valuePtr); -/* Slot 167 is reserved */ -/* Slot 168 is reserved */ +/* 167 */ +TCLAPI void TclSetStartupScriptPath(Tcl_Obj *pathPtr); +/* 168 */ +TCLAPI Tcl_Obj * TclGetStartupScriptPath(void); /* 169 */ TCLAPI int TclpUtfNcmp2(const char *s1, const char *s2, unsigned long n); @@ -428,8 +433,11 @@ TCLAPI void TclCleanupVar(Var *varPtr, Var *arrayPtr); TCLAPI void TclVarErrMsg(Tcl_Interp *interp, const char *part1, const char *part2, const char *operation, const char *reason); -/* Slot 178 is reserved */ -/* Slot 179 is reserved */ +/* 178 */ +TCLAPI void Tcl_SetStartupScript(Tcl_Obj *pathPtr, + const char *encodingName); +/* 179 */ +TCLAPI Tcl_Obj * Tcl_GetStartupScript(const char **encodingNamePtr); /* Slot 180 is reserved */ /* Slot 181 is reserved */ /* Slot 182 is reserved */ @@ -743,8 +751,8 @@ typedef struct TclIntStubs { void (*reserved155)(void); void (*tclRegError) (Tcl_Interp *interp, const char *msg, int status); /* 156 */ Var * (*tclVarTraceExists) (Tcl_Interp *interp, const char *varName); /* 157 */ - void (*reserved158)(void); - void (*reserved159)(void); + void (*tclSetStartupScriptFileName) (const char *filename); /* 158 */ + const char * (*tclGetStartupScriptFileName) (void); /* 159 */ void (*reserved160)(void); int (*tclChannelTransform) (Tcl_Interp *interp, Tcl_Channel chan, Tcl_Obj *cmdObjPtr); /* 161 */ void (*tclChannelEventScriptInvoker) (ClientData clientData, int flags); /* 162 */ @@ -752,8 +760,8 @@ typedef struct TclIntStubs { void (*tclExpandCodeArray) (void *envPtr); /* 164 */ void (*tclpSetInitialEncodings) (void); /* 165 */ int (*tclListObjSetElement) (Tcl_Interp *interp, Tcl_Obj *listPtr, int index, Tcl_Obj *valuePtr); /* 166 */ - void (*reserved167)(void); - void (*reserved168)(void); + void (*tclSetStartupScriptPath) (Tcl_Obj *pathPtr); /* 167 */ + Tcl_Obj * (*tclGetStartupScriptPath) (void); /* 168 */ int (*tclpUtfNcmp2) (const char *s1, const char *s2, unsigned long n); /* 169 */ int (*tclCheckInterpTraces) (Tcl_Interp *interp, const char *command, int numChars, Command *cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *const objv[]); /* 170 */ int (*tclCheckExecutionTraces) (Tcl_Interp *interp, const char *command, int numChars, Command *cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *const objv[]); /* 171 */ @@ -763,8 +771,8 @@ typedef struct TclIntStubs { int (*tclCallVarTraces) (Interp *iPtr, Var *arrayPtr, Var *varPtr, const char *part1, const char *part2, int flags, int leaveErrMsg); /* 175 */ void (*tclCleanupVar) (Var *varPtr, Var *arrayPtr); /* 176 */ void (*tclVarErrMsg) (Tcl_Interp *interp, const char *part1, const char *part2, const char *operation, const char *reason); /* 177 */ - void (*reserved178)(void); - void (*reserved179)(void); + void (*tcl_SetStartupScript) (Tcl_Obj *pathPtr, const char *encodingName); /* 178 */ + Tcl_Obj * (*tcl_GetStartupScript) (const char **encodingNamePtr); /* 179 */ void (*reserved180)(void); void (*reserved181)(void); void (*reserved182)(void); @@ -1105,8 +1113,10 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclRegError) /* 156 */ #define TclVarTraceExists \ (tclIntStubsPtr->tclVarTraceExists) /* 157 */ -/* Slot 158 is reserved */ -/* Slot 159 is reserved */ +#define TclSetStartupScriptFileName \ + (tclIntStubsPtr->tclSetStartupScriptFileName) /* 158 */ +#define TclGetStartupScriptFileName \ + (tclIntStubsPtr->tclGetStartupScriptFileName) /* 159 */ /* Slot 160 is reserved */ #define TclChannelTransform \ (tclIntStubsPtr->tclChannelTransform) /* 161 */ @@ -1120,8 +1130,10 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclpSetInitialEncodings) /* 165 */ #define TclListObjSetElement \ (tclIntStubsPtr->tclListObjSetElement) /* 166 */ -/* Slot 167 is reserved */ -/* Slot 168 is reserved */ +#define TclSetStartupScriptPath \ + (tclIntStubsPtr->tclSetStartupScriptPath) /* 167 */ +#define TclGetStartupScriptPath \ + (tclIntStubsPtr->tclGetStartupScriptPath) /* 168 */ #define TclpUtfNcmp2 \ (tclIntStubsPtr->tclpUtfNcmp2) /* 169 */ #define TclCheckInterpTraces \ @@ -1139,8 +1151,10 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclCleanupVar) /* 176 */ #define TclVarErrMsg \ (tclIntStubsPtr->tclVarErrMsg) /* 177 */ -/* Slot 178 is reserved */ -/* Slot 179 is reserved */ +#define Tcl_SetStartupScript \ + (tclIntStubsPtr->tcl_SetStartupScript) /* 178 */ +#define Tcl_GetStartupScript \ + (tclIntStubsPtr->tcl_GetStartupScript) /* 179 */ /* Slot 180 is reserved */ /* Slot 181 is reserved */ /* Slot 182 is reserved */ @@ -1259,4 +1273,58 @@ extern const TclIntStubs *tclIntStubsPtr; /* !END!: Do not edit above this line. */ +#undef TCL_STORAGE_CLASS +#define TCL_STORAGE_CLASS DLLIMPORT + +#undef TclGetStartupScriptFileName +#undef TclSetStartupScriptFileName +#undef TclGetStartupScriptPath +#undef TclSetStartupScriptPath +#undef TclBackgroundException + +#if defined(USE_TCL_STUBS) && defined(TCL_NO_DEPRECATED) +# undef Tcl_SetStartupScript +# define Tcl_SetStartupScript \ + (tclStubsPtr->tcl_SetStartupScript) /* 622 */ +# undef Tcl_GetStartupScript +# define Tcl_GetStartupScript \ + (tclStubsPtr->tcl_GetStartupScript) /* 623 */ +# undef Tcl_CreateNamespace +# define Tcl_CreateNamespace \ + (tclStubsPtr->tcl_CreateNamespace) /* 506 */ +# undef Tcl_DeleteNamespace +# define Tcl_DeleteNamespace \ + (tclStubsPtr->tcl_DeleteNamespace) /* 507 */ +# undef Tcl_AppendExportList +# define Tcl_AppendExportList \ + (tclStubsPtr->tcl_AppendExportList) /* 508 */ +# undef Tcl_Export +# define Tcl_Export \ + (tclStubsPtr->tcl_Export) /* 509 */ +# undef Tcl_Import +# define Tcl_Import \ + (tclStubsPtr->tcl_Import) /* 510 */ +# undef Tcl_ForgetImport +# define Tcl_ForgetImport \ + (tclStubsPtr->tcl_ForgetImport) /* 511 */ +# undef Tcl_GetCurrentNamespace +# define Tcl_GetCurrentNamespace \ + (tclStubsPtr->tcl_GetCurrentNamespace) /* 512 */ +# undef Tcl_GetGlobalNamespace +# define Tcl_GetGlobalNamespace \ + (tclStubsPtr->tcl_GetGlobalNamespace) /* 513 */ +# undef Tcl_FindNamespace +# define Tcl_FindNamespace \ + (tclStubsPtr->tcl_FindNamespace) /* 514 */ +# undef Tcl_FindCommand +# define Tcl_FindCommand \ + (tclStubsPtr->tcl_FindCommand) /* 515 */ +# undef Tcl_GetCommandFromObj +# define Tcl_GetCommandFromObj \ + (tclStubsPtr->tcl_GetCommandFromObj) /* 516 */ +# undef Tcl_GetCommandFullName +# define Tcl_GetCommandFullName \ + (tclStubsPtr->tcl_GetCommandFullName) /* 517 */ +#endif + #endif /* _TCLINTDECLS */ diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h index 80d6236..f7eb442 100644 --- a/generic/tclIntPlatDecls.h +++ b/generic/tclIntPlatDecls.h @@ -71,10 +71,7 @@ TCLAPI int TclUnixCopyFile(const char *src, const char *dst, /* Slot 17 is reserved */ /* Slot 18 is reserved */ /* Slot 19 is reserved */ -/* 20 */ -TCLAPI int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, - Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, - Tcl_Obj *resultingNameObj); +/* Slot 20 is reserved */ /* Slot 21 is reserved */ /* Slot 22 is reserved */ /* Slot 23 is reserved */ @@ -85,6 +82,10 @@ TCLAPI int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, /* Slot 28 is reserved */ /* 29 */ TCLAPI int TclWinCPUID(unsigned int index, unsigned int *regs); +/* 30 */ +TCLAPI int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, + Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, + Tcl_Obj *resultingNameObj); #endif /* UNIX */ #if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */ /* 0 */ @@ -155,6 +156,10 @@ TCLAPI void TclWinFlushDirtyChannels(void); TCLAPI void TclWinResetInterfaces(void); /* 29 */ TCLAPI int TclWinCPUID(unsigned int index, unsigned int *regs); +/* 30 */ +TCLAPI int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, + Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, + Tcl_Obj *resultingNameObj); #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ /* 0 */ @@ -212,10 +217,7 @@ TCLAPI int TclMacOSXMatchType(Tcl_Interp *interp, /* 19 */ TCLAPI void TclMacOSXNotifierAddRunLoopMode( const void *runLoopMode); -/* 20 */ -TCLAPI int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, - Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, - Tcl_Obj *resultingNameObj); +/* Slot 20 is reserved */ /* Slot 21 is reserved */ /* Slot 22 is reserved */ /* Slot 23 is reserved */ @@ -226,6 +228,10 @@ TCLAPI int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, /* Slot 28 is reserved */ /* 29 */ TCLAPI int TclWinCPUID(unsigned int index, unsigned int *regs); +/* 30 */ +TCLAPI int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, + Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, + Tcl_Obj *resultingNameObj); #endif /* MACOSX */ typedef struct TclIntPlatStubs { @@ -253,7 +259,7 @@ typedef struct TclIntPlatStubs { void (*reserved17)(void); void (*reserved18)(void); void (*reserved19)(void); - int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 20 */ + void (*reserved20)(void); void (*reserved21)(void); void (*reserved22)(void); void (*reserved23)(void); @@ -263,6 +269,7 @@ typedef struct TclIntPlatStubs { void (*reserved27)(void); void (*reserved28)(void); int (*tclWinCPUID) (unsigned int index, unsigned int *regs); /* 29 */ + int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */ #endif /* UNIX */ #if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */ void (*tclWinConvertError) (DWORD errCode); /* 0 */ @@ -295,6 +302,7 @@ typedef struct TclIntPlatStubs { void (*tclWinFlushDirtyChannels) (void); /* 27 */ void (*tclWinResetInterfaces) (void); /* 28 */ int (*tclWinCPUID) (unsigned int index, unsigned int *regs); /* 29 */ + int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 0 */ @@ -317,7 +325,7 @@ typedef struct TclIntPlatStubs { int (*tclMacOSXCopyFileAttributes) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr); /* 17 */ int (*tclMacOSXMatchType) (Tcl_Interp *interp, const char *pathName, const char *fileName, Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types); /* 18 */ void (*tclMacOSXNotifierAddRunLoopMode) (const void *runLoopMode); /* 19 */ - int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 20 */ + void (*reserved20)(void); void (*reserved21)(void); void (*reserved22)(void); void (*reserved23)(void); @@ -327,6 +335,7 @@ typedef struct TclIntPlatStubs { void (*reserved27)(void); void (*reserved28)(void); int (*tclWinCPUID) (unsigned int index, unsigned int *regs); /* 29 */ + int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */ #endif /* MACOSX */ } TclIntPlatStubs; @@ -377,8 +386,7 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; /* Slot 17 is reserved */ /* Slot 18 is reserved */ /* Slot 19 is reserved */ -#define TclUnixOpenTemporaryFile \ - (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 20 */ +/* Slot 20 is reserved */ /* Slot 21 is reserved */ /* Slot 22 is reserved */ /* Slot 23 is reserved */ @@ -389,6 +397,8 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; /* Slot 28 is reserved */ #define TclWinCPUID \ (tclIntPlatStubsPtr->tclWinCPUID) /* 29 */ +#define TclUnixOpenTemporaryFile \ + (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */ #endif /* UNIX */ #if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */ #define TclWinConvertError \ @@ -448,6 +458,8 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; (tclIntPlatStubsPtr->tclWinResetInterfaces) /* 28 */ #define TclWinCPUID \ (tclIntPlatStubsPtr->tclWinCPUID) /* 29 */ +#define TclUnixOpenTemporaryFile \ + (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ #define TclGetAndDetachPids \ @@ -487,8 +499,7 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; (tclIntPlatStubsPtr->tclMacOSXMatchType) /* 18 */ #define TclMacOSXNotifierAddRunLoopMode \ (tclIntPlatStubsPtr->tclMacOSXNotifierAddRunLoopMode) /* 19 */ -#define TclUnixOpenTemporaryFile \ - (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 20 */ +/* Slot 20 is reserved */ /* Slot 21 is reserved */ /* Slot 22 is reserved */ /* Slot 23 is reserved */ @@ -499,6 +510,8 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; /* Slot 28 is reserved */ #define TclWinCPUID \ (tclIntPlatStubsPtr->tclWinCPUID) /* 29 */ +#define TclUnixOpenTemporaryFile \ + (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */ #endif /* MACOSX */ #endif /* defined(USE_TCL_STUBS) */ diff --git a/generic/tclInterp.c b/generic/tclInterp.c index 0b0f652..d5d43ed 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -1798,9 +1798,9 @@ AliasNRCmd( */ if (isRootEnsemble) { - TclNRDeferCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL); + TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL); } - iPtr->evalFlags |= TCL_EVAL_REDIRECT; + TclSkipTailcall(interp); return Tcl_NREvalObj(interp, listPtr, flags); } diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 3668b45..2d1defa 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -909,6 +909,10 @@ Tcl_ListObjReplace( isShared = (listRepPtr->refCount > 1); numRequired = numElems - count + objc; + for (i = 0; i < objc; i++) { + Tcl_IncrRefCount(objv[i]); + } + if ((numRequired <= listRepPtr->maxElemCount) && !isShared) { int shift; @@ -963,6 +967,14 @@ Tcl_ListObjReplace( if (listRepPtr == NULL) { listRepPtr = AttemptNewList(interp, numRequired, NULL); if (listRepPtr == NULL) { + for (i = 0; i < objc; i++) { + /* See bug 3598580 */ +#if TCL_MAJOR_VERSION > 8 + Tcl_DecrRefCount(objv[i]); +#else + objv[i]->refCount--; +#endif + } return TCL_ERROR; } } @@ -1027,14 +1039,11 @@ Tcl_ListObjReplace( } /* - * Insert the new elements into elemPtrs before "first". We don't do a - * memcpy here because we must increment the reference counts for the - * added elements, so we must explicitly loop anyway. + * Insert the new elements into elemPtrs before "first". */ for (i=0,j=first ; i<objc ; i++,j++) { elemPtrs[j] = objv[i]; - Tcl_IncrRefCount(objv[i]); } /* diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 02d517f..304487b 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -160,23 +160,23 @@ static const Tcl_ObjType nsNameType = { */ static const EnsembleImplMap defaultNamespaceMap[] = { - {"children", NamespaceChildrenCmd, NULL, NULL, NULL, 0}, + {"children", NamespaceChildrenCmd, TclCompileBasic0To2ArgCmd, NULL, NULL, 0}, {"code", NamespaceCodeCmd, TclCompileNamespaceCodeCmd, NULL, NULL, 0}, {"current", NamespaceCurrentCmd, TclCompileNamespaceCurrentCmd, NULL, NULL, 0}, - {"delete", NamespaceDeleteCmd, NULL, NULL, NULL, 0}, + {"delete", NamespaceDeleteCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0}, {"ensemble", TclNamespaceEnsembleCmd, NULL, NULL, NULL, 0}, {"eval", NamespaceEvalCmd, NULL, NRNamespaceEvalCmd, NULL, 0}, - {"exists", NamespaceExistsCmd, NULL, NULL, NULL, 0}, - {"export", NamespaceExportCmd, NULL, NULL, NULL, 0}, - {"forget", NamespaceForgetCmd, NULL, NULL, NULL, 0}, - {"import", NamespaceImportCmd, NULL, NULL, NULL, 0}, + {"exists", NamespaceExistsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"export", NamespaceExportCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0}, + {"forget", NamespaceForgetCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0}, + {"import", NamespaceImportCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0}, {"inscope", NamespaceInscopeCmd, NULL, NRNamespaceInscopeCmd, NULL, 0}, - {"origin", NamespaceOriginCmd, NULL, NULL, NULL, 0}, - {"parent", NamespaceParentCmd, NULL, NULL, NULL, 0}, - {"path", NamespacePathCmd, NULL, NULL, NULL, 0}, + {"origin", NamespaceOriginCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"parent", NamespaceParentCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, + {"path", NamespacePathCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, {"qualifiers", NamespaceQualifiersCmd, TclCompileNamespaceQualifiersCmd, NULL, NULL, 0}, {"tail", NamespaceTailCmd, TclCompileNamespaceTailCmd, NULL, NULL, 0}, - {"unknown", NamespaceUnknownCmd, NULL, NULL, NULL, 0}, + {"unknown", NamespaceUnknownCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, {"upvar", NamespaceUpvarCmd, TclCompileNamespaceUpvarCmd, NULL, NULL, 0}, {"which", NamespaceWhichCmd, TclCompileNamespaceWhichCmd, NULL, NULL, 0}, {NULL, NULL, NULL, NULL, NULL, 0} @@ -423,7 +423,7 @@ Tcl_PopCallFrame( framePtr->nsPtr = NULL; if (framePtr->tailcallPtr) { - TclSpliceTailcall(interp, framePtr->tailcallPtr); + TclSetTailcall(interp, framePtr->tailcallPtr); } } @@ -1945,7 +1945,7 @@ InvokeImportedNRCmd( ImportedCmdData *dataPtr = clientData; Command *realCmdPtr = dataPtr->realCmdPtr; - ((Interp *) interp)->evalFlags |= TCL_EVAL_REDIRECT; + TclSkipTailcall(interp); return Tcl_NRCmdSwap(interp, (Tcl_Command) realCmdPtr, objc, objv, 0); } diff --git a/generic/tclOO.c b/generic/tclOO.c index d6d2d6a..cb22de6 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -843,7 +843,7 @@ ObjectRenamedTrace( result = Tcl_NRCallObjProc(interp, TclOOInvokeContext, contextPtr, 0, NULL); if (result != TCL_OK) { - Tcl_BackgroundError(interp); + Tcl_BackgroundException(interp, result); } Tcl_RestoreInterpState(interp, state); TclOODeleteContext(contextPtr); diff --git a/generic/tclOO.h b/generic/tclOO.h index 280481c..cf253b1 100644 --- a/generic/tclOO.h +++ b/generic/tclOO.h @@ -39,7 +39,7 @@ extern const char *TclOOInitializeStubs( * win/tclooConfig.sh */ -#define TCLOO_VERSION "0.7" +#define TCLOO_VERSION "1.0" #define TCLOO_PATCHLEVEL TCLOO_VERSION /* diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c index e09ee4e..3217f98 100644 --- a/generic/tclOOInfo.c +++ b/generic/tclOOInfo.c @@ -48,18 +48,18 @@ static Tcl_ObjCmdProc InfoClassVariablesCmd; */ static const EnsembleImplMap infoObjectCmds[] = { - {"call", InfoObjectCallCmd, NULL, NULL, NULL, 0}, + {"call", InfoObjectCallCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"class", InfoObjectClassCmd, TclCompileInfoObjectClassCmd, NULL, NULL, 0}, - {"definition", InfoObjectDefnCmd, NULL, NULL, NULL, 0}, - {"filters", InfoObjectFiltersCmd, NULL, NULL, NULL, 0}, - {"forward", InfoObjectForwardCmd, NULL, NULL, NULL, 0}, + {"definition", InfoObjectDefnCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, + {"filters", InfoObjectFiltersCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"forward", InfoObjectForwardCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"isa", InfoObjectIsACmd, TclCompileInfoObjectIsACmd, NULL, NULL, 0}, - {"methods", InfoObjectMethodsCmd, NULL, NULL, NULL, 0}, - {"methodtype", InfoObjectMethodTypeCmd, NULL, NULL, NULL, 0}, - {"mixins", InfoObjectMixinsCmd, NULL, NULL, NULL, 0}, + {"methods", InfoObjectMethodsCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0}, + {"methodtype", InfoObjectMethodTypeCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, + {"mixins", InfoObjectMixinsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"namespace", InfoObjectNsCmd, TclCompileInfoObjectNamespaceCmd, NULL, NULL, 0}, - {"variables", InfoObjectVariablesCmd, NULL, NULL, NULL, 0}, - {"vars", InfoObjectVarsCmd, NULL, NULL, NULL, 0}, + {"variables", InfoObjectVariablesCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"vars", InfoObjectVarsCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, {NULL, NULL, NULL, NULL, NULL, 0} }; @@ -68,19 +68,19 @@ static const EnsembleImplMap infoObjectCmds[] = { */ static const EnsembleImplMap infoClassCmds[] = { - {"call", InfoClassCallCmd, NULL, NULL, NULL, 0}, - {"constructor", InfoClassConstrCmd, NULL, NULL, NULL, 0}, - {"definition", InfoClassDefnCmd, NULL, NULL, NULL, 0}, - {"destructor", InfoClassDestrCmd, NULL, NULL, NULL, 0}, - {"filters", InfoClassFiltersCmd, NULL, NULL, NULL, 0}, - {"forward", InfoClassForwardCmd, NULL, NULL, NULL, 0}, - {"instances", InfoClassInstancesCmd, NULL, NULL, NULL, 0}, - {"methods", InfoClassMethodsCmd, NULL, NULL, NULL, 0}, - {"methodtype", InfoClassMethodTypeCmd, NULL, NULL, NULL, 0}, - {"mixins", InfoClassMixinsCmd, NULL, NULL, NULL, 0}, - {"subclasses", InfoClassSubsCmd, NULL, NULL, NULL, 0}, - {"superclasses", InfoClassSupersCmd, NULL, NULL, NULL, 0}, - {"variables", InfoClassVariablesCmd, NULL, NULL, NULL, 0}, + {"call", InfoClassCallCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, + {"constructor", InfoClassConstrCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"definition", InfoClassDefnCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, + {"destructor", InfoClassDestrCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"filters", InfoClassFiltersCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"forward", InfoClassForwardCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, + {"instances", InfoClassInstancesCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, + {"methods", InfoClassMethodsCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0}, + {"methodtype", InfoClassMethodTypeCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, + {"mixins", InfoClassMixinsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"subclasses", InfoClassSubsCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, + {"superclasses", InfoClassSupersCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"variables", InfoClassVariablesCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {NULL, NULL, NULL, NULL, NULL, 0} }; @@ -100,6 +100,7 @@ TclOOInitInfo( Tcl_Interp *interp) { Tcl_Command infoCmd; + Tcl_Obj *mapDict; /* * Build the ensembles used to implement [info object] and [info class]. @@ -113,25 +114,12 @@ TclOOInitInfo( */ infoCmd = Tcl_FindCommand(interp, "info", NULL, TCL_GLOBAL_ONLY); - if (infoCmd != NULL && Tcl_IsEnsemble(infoCmd)) { - Tcl_Obj *mapDict, *objectObj, *classObj; - - Tcl_GetEnsembleMappingDict(NULL, infoCmd, &mapDict); - if (mapDict != NULL) { - objectObj = Tcl_NewStringObj("object", -1); - classObj = Tcl_NewStringObj("class", -1); - - Tcl_IncrRefCount(objectObj); - Tcl_IncrRefCount(classObj); - Tcl_DictObjPut(NULL, mapDict, objectObj, - Tcl_NewStringObj("::oo::InfoObject", -1)); - Tcl_DictObjPut(NULL, mapDict, classObj, - Tcl_NewStringObj("::oo::InfoClass", -1)); - Tcl_DecrRefCount(objectObj); - Tcl_DecrRefCount(classObj); - Tcl_SetEnsembleMappingDict(interp, infoCmd, mapDict); - } - } + Tcl_GetEnsembleMappingDict(NULL, infoCmd, &mapDict); + Tcl_DictObjPut(NULL, mapDict, Tcl_NewStringObj("object", -1), + Tcl_NewStringObj("::oo::InfoObject", -1)); + Tcl_DictObjPut(NULL, mapDict, Tcl_NewStringObj("class", -1), + Tcl_NewStringObj("::oo::InfoClass", -1)); + Tcl_SetEnsembleMappingDict(interp, infoCmd, mapDict); } /* diff --git a/generic/tclOOStubLib.c b/generic/tclOOStubLib.c index 55f2378..921aced 100644 --- a/generic/tclOOStubLib.c +++ b/generic/tclOOStubLib.c @@ -2,19 +2,6 @@ * ORIGINAL SOURCE: tk/generic/tkStubLib.c, version 1.9 2004/03/17 */ -/* - * We need to ensure that we use the tcl stub macros so that this file - * contains no references to any of the tcl stub functions. - */ - -#undef USE_TCL_STUBS -#define USE_TCL_STUBS - -#ifdef HAVE_CONFIG_H -#include "config.h" -#endif - -#define USE_TCLOO_STUBS 1 #include "tclOOInt.h" MODULE_SCOPE const TclOOStubs *tclOOStubsPtr; @@ -35,51 +22,48 @@ const TclOOIntStubs *tclOOIntStubsPtr = NULL; * to indicate that an error occurred. * * Side effects: - * Sets the stub table pointer. + * Sets the stub table pointers. * *---------------------------------------------------------------------- */ MODULE_SCOPE const char * TclOOInitializeStubs( - Tcl_Interp *interp, const char *version) + Tcl_Interp *interp, + const char *version) { int exact = 0; const char *packageName = "TclOO"; const char *errMsg = NULL; - ClientData clientData = NULL; - const char *actualVersion = - Tcl_PkgRequireEx(interp, packageName,version, exact, &clientData); + TclOOStubs *stubsPtr = NULL; + const char *actualVersion = tclStubsPtr->tcl_PkgRequireEx(interp, + packageName, version, exact, &stubsPtr); - if (clientData == NULL) { - Tcl_ResetResult(interp); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "error loading %s package; package not present or incomplete", - packageName)); + if (actualVersion == NULL) { return NULL; + } + if (stubsPtr == NULL) { + errMsg = "missing stub table pointer"; } else { - const TclOOStubs * const stubsPtr = clientData; - const TclOOIntStubs * const intStubsPtr = stubsPtr->hooks ? - stubsPtr->hooks->tclOOIntStubs : NULL; - - if (!actualVersion) { - return NULL; - } - - if (!stubsPtr || !intStubsPtr) { - errMsg = "missing stub table pointer"; - goto error; - } - tclOOStubsPtr = stubsPtr; - tclOOIntStubsPtr = intStubsPtr; + if (stubsPtr->hooks) { + tclOOIntStubsPtr = stubsPtr->hooks->tclOOIntStubs; + } else { + tclOOIntStubsPtr = NULL; + } return actualVersion; - - error: - Tcl_ResetResult(interp); - Tcl_SetObjResult(interp, Tcl_ObjPrintf("Error loading %s package" - " (requested version '%s', loaded version '%s'): %s", - packageName, version, actualVersion, errMsg)); - return NULL; } + tclStubsPtr->tcl_ResetResult(interp); + tclStubsPtr->tcl_AppendResult(interp, "Error loading ", packageName, + " (requested version ", version, ", actual version ", + actualVersion, "): ", errMsg, NULL); + return NULL; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclPkg.c b/generic/tclPkg.c index 9b6e942..5b09ddb 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -356,6 +356,10 @@ PkgRequireCore( char *script, *pkgVersionI; Tcl_DString command; + if (TCL_OK != CheckAllRequirements(interp, reqc, reqv)) { + return NULL; + } + /* * It can take up to three passes to find the package: one pass to run the * "package unknown" script, one to run the "package ifneeded" script for diff --git a/generic/tclPort.h b/generic/tclPort.h index 7021b8d..12a60db 100644 --- a/generic/tclPort.h +++ b/generic/tclPort.h @@ -19,11 +19,10 @@ #endif #if defined(_WIN32) # include "tclWinPort.h" -#endif -#include "tcl.h" -#if !defined(_WIN32) +#else # include "tclUnixPort.h" #endif +#include "tcl.h" #if !defined(LLONG_MIN) # ifdef TCL_WIDE_INT_IS_LONG diff --git a/generic/tclResult.c b/generic/tclResult.c index 618b7d8..5329e14 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -1278,7 +1278,7 @@ Tcl_GetReturnOptions( } if (result == TCL_ERROR) { - Tcl_AddObjErrorInfo(interp, "", -1); + Tcl_AddErrorInfo(interp, ""); Tcl_DictObjPut(NULL, options, keys[KEY_ERRORSTACK], iPtr->errorStack); } if (iPtr->errorCode) { diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 6718ef8..2881644 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -41,6 +41,31 @@ #undef Tcl_FindExecutable #undef TclpGetPid #undef TclSockMinimumBuffers +#define TclSetStartupScriptPath setStartupScriptPath +static void TclSetStartupScriptPath(Tcl_Obj *path) +{ + Tcl_SetStartupScript(path, NULL); +} +#define TclGetStartupScriptPath getStartupScriptPath +static Tcl_Obj *TclGetStartupScriptPath(void) +{ + return Tcl_GetStartupScript(NULL); +} +#define TclSetStartupScriptFileName setStartupScriptFileName +static void TclSetStartupScriptFileName( + const char *fileName) +{ + Tcl_SetStartupScript(Tcl_NewStringObj(fileName,-1), NULL); +} +#define TclGetStartupScriptFileName getStartupScriptFileName +static const char *TclGetStartupScriptFileName(void) +{ + Tcl_Obj *path = Tcl_GetStartupScript(NULL); + if (path == NULL) { + return NULL; + } + return Tcl_GetStringFromObj(path, NULL); +} #if defined(_WIN32) || defined(__CYGWIN__) #undef TclWinNToHS @@ -53,6 +78,7 @@ static unsigned short TclWinNToHS(unsigned short ns) { #ifdef __WIN32__ # define TclUnixWaitForFile 0 # define TclUnixCopyFile 0 +# define TclUnixOpenTemporaryFile 0 # define TclpReaddir 0 # define TclpIsAtty 0 #elif defined(__CYGWIN__) @@ -331,8 +357,8 @@ static const TclIntStubs tclIntStubs = { 0, /* 155 */ TclRegError, /* 156 */ TclVarTraceExists, /* 157 */ - 0, /* 158 */ - 0, /* 159 */ + TclSetStartupScriptFileName, /* 158 */ + TclGetStartupScriptFileName, /* 159 */ 0, /* 160 */ TclChannelTransform, /* 161 */ TclChannelEventScriptInvoker, /* 162 */ @@ -340,8 +366,8 @@ static const TclIntStubs tclIntStubs = { TclExpandCodeArray, /* 164 */ TclpSetInitialEncodings, /* 165 */ TclListObjSetElement, /* 166 */ - 0, /* 167 */ - 0, /* 168 */ + TclSetStartupScriptPath, /* 167 */ + TclGetStartupScriptPath, /* 168 */ TclpUtfNcmp2, /* 169 */ TclCheckInterpTraces, /* 170 */ TclCheckExecutionTraces, /* 171 */ @@ -351,8 +377,8 @@ static const TclIntStubs tclIntStubs = { TclCallVarTraces, /* 175 */ TclCleanupVar, /* 176 */ TclVarErrMsg, /* 177 */ - 0, /* 178 */ - 0, /* 179 */ + Tcl_SetStartupScript, /* 178 */ + Tcl_GetStartupScript, /* 179 */ 0, /* 180 */ 0, /* 181 */ 0, /* 182 */ @@ -450,7 +476,7 @@ static const TclIntPlatStubs tclIntPlatStubs = { 0, /* 17 */ 0, /* 18 */ 0, /* 19 */ - TclUnixOpenTemporaryFile, /* 20 */ + 0, /* 20 */ 0, /* 21 */ 0, /* 22 */ 0, /* 23 */ @@ -460,6 +486,7 @@ static const TclIntPlatStubs tclIntPlatStubs = { 0, /* 27 */ 0, /* 28 */ TclWinCPUID, /* 29 */ + TclUnixOpenTemporaryFile, /* 30 */ #endif /* UNIX */ #if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */ TclWinConvertError, /* 0 */ @@ -492,6 +519,7 @@ static const TclIntPlatStubs tclIntPlatStubs = { TclWinFlushDirtyChannels, /* 27 */ TclWinResetInterfaces, /* 28 */ TclWinCPUID, /* 29 */ + TclUnixOpenTemporaryFile, /* 30 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ TclGetAndDetachPids, /* 0 */ @@ -514,7 +542,7 @@ static const TclIntPlatStubs tclIntPlatStubs = { TclMacOSXCopyFileAttributes, /* 17 */ TclMacOSXMatchType, /* 18 */ TclMacOSXNotifierAddRunLoopMode, /* 19 */ - TclUnixOpenTemporaryFile, /* 20 */ + 0, /* 20 */ 0, /* 21 */ 0, /* 22 */ 0, /* 23 */ @@ -524,6 +552,7 @@ static const TclIntPlatStubs tclIntPlatStubs = { 0, /* 27 */ 0, /* 28 */ TclWinCPUID, /* 29 */ + TclUnixOpenTemporaryFile, /* 30 */ #endif /* MACOSX */ }; diff --git a/generic/tclStubLib.c b/generic/tclStubLib.c index 9a2e063..47eefc3 100644 --- a/generic/tclStubLib.c +++ b/generic/tclStubLib.c @@ -11,15 +11,6 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -/* - * We need to ensure that we use the stub macros so that this file contains no - * references to any of the stub functions. This will make it possible to - * build an extension that references Tcl_InitStubs but doesn't end up - * including the rest of the stub functions. - */ - -#define USE_TCL_STUBS - #include "tclInt.h" MODULE_SCOPE const TclStubs *tclStubsPtr; @@ -32,28 +23,8 @@ const TclPlatStubs *tclPlatStubsPtr = NULL; const TclIntStubs *tclIntStubsPtr = NULL; const TclIntPlatStubs *tclIntPlatStubsPtr = NULL; -static const TclStubs * -HasStubSupport( - Tcl_Interp *interp, - const char *tclversion, - int magic) -{ - /* TODO: Whatever additional checks using tclversion - * and/or magic should be done here. */ - - Interp *iPtr = (Interp *) interp; - - if (iPtr->stubTable && iPtr->stubTable->magic == magic) { - return iPtr->stubTable; - } - iPtr->legacyResult - = "interpreter uses an incompatible stubs mechanism"; - iPtr->legacyFreeProc = 0; /* TCL_STATIC */ - return NULL; -} - /* - * Use our own isdigit to avoid linking to libc on windows + * Use our own isDigit to avoid linking to libc on windows */ static int isDigit(const int c) @@ -78,7 +49,7 @@ static int isDigit(const int c) * *---------------------------------------------------------------------- */ - +#undef Tcl_InitStubs MODULE_SCOPE const char * TclInitStubs( Tcl_Interp *interp, @@ -87,8 +58,10 @@ TclInitStubs( const char *tclversion, int magic) { + Interp *iPtr = (Interp *) interp; const char *actualVersion = NULL; ClientData pkgData = NULL; + const TclStubs *stubsPtr = iPtr->stubTable; /* * We can't optimize this check by caching tclStubsPtr because that @@ -96,12 +69,14 @@ TclInitStubs( * times. [Bug 615304] */ - tclStubsPtr = HasStubSupport(interp, tclversion, magic); - if (!tclStubsPtr) { + if (!stubsPtr || (stubsPtr->magic != TCL_STUB_MAGIC)) { + iPtr->legacyResult = + "interpreter uses an incompatible stubs mechanism"; + iPtr->legacyFreeProc = 0; /* TCL_STATIC */ return NULL; } - actualVersion = Tcl_PkgRequireEx(interp, "Tcl", version, 0, &pkgData); + actualVersion = stubsPtr->tcl_PkgRequireEx(interp, "Tcl", version, 0, &pkgData); if (actualVersion == NULL) { return NULL; } @@ -119,19 +94,19 @@ TclInitStubs( while (*p && (*p == *q)) { p++; q++; } - if (*p) { + if (*p || isDigit(*q)) { /* Construct error message */ - Tcl_PkgRequireEx(interp, "Tcl", version, 1, NULL); + stubsPtr->tcl_PkgRequireEx(interp, "Tcl", version, 1, NULL); return NULL; } } else { - actualVersion = Tcl_PkgRequireEx(interp, "Tcl", version, 1, NULL); + actualVersion = stubsPtr->tcl_PkgRequireEx(interp, "Tcl", version, 1, NULL); if (actualVersion == NULL) { return NULL; } } } - tclStubsPtr = (TclStubs *) pkgData; + tclStubsPtr = (TclStubs *)pkgData; if (tclStubsPtr->hooks) { tclPlatStubsPtr = tclStubsPtr->hooks->tclPlatStubs; diff --git a/generic/tclTest.c b/generic/tclTest.c index 9b958dd..ef5a25a 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -19,6 +19,7 @@ #ifndef USE_TCL_STUBS # define USE_TCL_STUBS #endif +#include <sys/stat.h> #include "tclInt.h" #include "tclOO.h" #include <math.h> diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index 7494beb..4bddc42 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -963,6 +963,17 @@ TestobjCmd( } SetVarToObj(varPtr, destIndex, varPtr[varIndex]); Tcl_SetObjResult(interp, varPtr[destIndex]); + } else if (strcmp(subCmd, "bug3598580") == 0) { + Tcl_Obj *listObjPtr, *elemObjPtr; + if (objc != 2) { + goto wrongNumArgs; + } + elemObjPtr = Tcl_NewIntObj(123); + listObjPtr = Tcl_NewListObj(1, &elemObjPtr); + /* Replace the single list element through itself, nonsense but legal. */ + Tcl_ListObjReplace(interp, listObjPtr, 0, 1, 1, &elemObjPtr); + Tcl_SetObjResult(interp, listObjPtr); + return TCL_OK; } else if (strcmp(subCmd, "convert") == 0) { const char *typeName; diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c index c1828bb..38dd010 100644 --- a/generic/tclThreadTest.c +++ b/generic/tclThreadTest.c @@ -513,7 +513,6 @@ ThreadCreate( TCL_THREAD_STACK_DEFAULT, joinable) != TCL_OK) { Tcl_MutexUnlock(&threadMutex); Tcl_AppendResult(interp, "can't create a new thread", NULL); - ckfree(ctrl.script); return TCL_ERROR; } @@ -927,10 +926,11 @@ ThreadSend( ckfree(resultPtr->errorInfo); } } - Tcl_SetResult(interp, resultPtr->result, TCL_DYNAMIC); + Tcl_AppendResult(interp, resultPtr->result, NULL); Tcl_ConditionFinalize(&resultPtr->done); code = resultPtr->code; + ckfree(resultPtr->result); ckfree(resultPtr); return code; diff --git a/generic/tclTomMathInterface.c b/generic/tclTomMathInterface.c index 775e86b..48db8c3 100644 --- a/generic/tclTomMathInterface.c +++ b/generic/tclTomMathInterface.c @@ -111,7 +111,7 @@ extern void * TclBNAlloc( size_t x) { - return (void *) Tcl_Alloc((unsigned int) x); + return (void *) ckalloc((unsigned int) x); } /* @@ -135,7 +135,7 @@ TclBNRealloc( void *p, size_t s) { - return (void *) Tcl_Realloc((char *) p, (unsigned int) s); + return (void *) ckrealloc((char *) p, (unsigned int) s); } /* @@ -161,7 +161,7 @@ extern void TclBNFree( void *p) { - Tcl_Free((char *) p); + ckree((char *) p); } #endif diff --git a/generic/tclTomMathStubLib.c b/generic/tclTomMathStubLib.c index a3bc4b3..324f2a3 100644 --- a/generic/tclTomMathStubLib.c +++ b/generic/tclTomMathStubLib.c @@ -11,15 +11,6 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -/* - * We need to ensure that we use the stub macros so that this file contains no - * references to any of the stub functions. This will make it possible to - * build an extension that references Tcl_InitStubs but doesn't end up - * including the rest of the stub functions. - */ - -#define USE_TCL_STUBS - #include "tclInt.h" MODULE_SCOPE const TclTomMathStubs *tclTomMathStubsPtr; @@ -55,31 +46,30 @@ TclTomMathInitializeStubs( int exact = 0; const char *packageName = "tcl::tommath"; const char *errMsg = NULL; - ClientData pkgClientData = NULL; - const char *actualVersion = - Tcl_PkgRequireEx(interp, packageName, version, exact, &pkgClientData); - const TclTomMathStubs *stubsPtr = pkgClientData; + TclTomMathStubs *stubsPtr = NULL; + const char *actualVersion = tclStubsPtr->tcl_PkgRequireEx(interp, + packageName, version, exact, &stubsPtr); if (actualVersion == NULL) { return NULL; } - if (pkgClientData == NULL) { + if (stubsPtr == NULL) { errMsg = "missing stub table pointer"; - } else if ((stubsPtr->tclBN_epoch)() != epoch) { + } else if(stubsPtr->tclBN_epoch() != epoch) { errMsg = "epoch number mismatch"; - } else if ((stubsPtr->tclBN_revision)() != revision) { + } else if(stubsPtr->tclBN_revision() != revision) { errMsg = "requires a later revision"; } else { tclTomMathStubsPtr = stubsPtr; return actualVersion; } - - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "error loading %s (requested version %s, actual version %s): %s", - packageName, version, actualVersion, errMsg)); + tclStubsPtr->tcl_ResetResult(interp); + tclStubsPtr->tcl_AppendResult(interp, "Error loading ", packageName, + " (requested version ", version, ", actual version ", + actualVersion, "): ", errMsg, NULL); return NULL; } - + /* * Local Variables: * mode: c diff --git a/generic/tclTrace.c b/generic/tclTrace.c index 519f201..0f297a4 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -1322,7 +1322,7 @@ TraceCommandProc( Tcl_DStringLength(&cmd), 0); if (code != TCL_OK) { /* We ignore errors in these traced commands */ - /*** QUESTION: Use Tcl_BackgroundError(interp); instead? ***/ + /*** QUESTION: Use Tcl_BackgroundException(interp, code); instead? ***/ } Tcl_DStringFree(&cmd); } diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 4b69628..df257e8 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -167,7 +167,7 @@ const Tcl_ObjType tclEndOffsetType = { * separating whitespace, or a string terminator. It is just another * character in a list element. * - * The interpretaton of a formatted substring as a list element follows rules + * The interpretation of a formatted substring as a list element follows rules * similar to the parsing of the words of a command in a Tcl script. Backslash * substitution plays a key role, and is defined exactly as it is in command * parsing. The same routine, TclParseBackslash() is used in both command @@ -179,7 +179,7 @@ const Tcl_ObjType tclEndOffsetType = { * Backslash substitution replaces an "escape sequence" of one or more * characters starting with * \u005c \ BACKSLASH - * with a single character. The one character escape sequent case happens only + * with a single character. The one character escape sequence case happens only * when BACKSLASH is the last character in the string. In all other cases, the * escape sequence is at least two characters long. * @@ -2827,14 +2827,16 @@ TclDStringToObj( { Tcl_Obj *result; - if (dsPtr->length == 0) { - TclNewObj(result); - } else if (dsPtr->string == dsPtr->staticSpace) { - /* - * Static buffer, so must copy. - */ - - TclNewStringObj(result, dsPtr->string, dsPtr->length); + if (dsPtr->string == dsPtr->staticSpace) { + if (dsPtr->length == 0) { + TclNewObj(result); + } else { + /* + * Static buffer, so must copy. + */ + + TclNewStringObj(result, dsPtr->string, dsPtr->length); + } } else { /* * Dynamic buffer, so transfer ownership and reset. diff --git a/generic/tclVar.c b/generic/tclVar.c index d8a7141..1a81048 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -47,6 +47,13 @@ static inline void CleanupVar(Var *varPtr, Var *arrayPtr); #define VarHashGetValue(hPtr) \ ((Var *) ((char *)hPtr - TclOffset(VarInHash, entry))) +/* + * NOTE: VarHashCreateVar increments the recount of its key argument. + * All callers that will call Tcl_DecrRefCount on that argument must + * call Tcl_IncrRefCount on it before passing it in. This requirement + * can bubble up to callers of callers .... etc. + */ + static inline Var * VarHashCreateVar( TclVarHashTable *tablePtr, @@ -383,11 +390,12 @@ TclLookupVar( * address of array variable. Otherwise this * is set to NULL. */ { - Tcl_Obj *part1Ptr; Var *varPtr; + Tcl_Obj *part1Ptr = Tcl_NewStringObj(part1, -1); - part1Ptr = Tcl_NewStringObj(part1, -1); - Tcl_IncrRefCount(part1Ptr); + if (createPart1) { + Tcl_IncrRefCount(part1Ptr); + } varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, msg, createPart1, createPart2, arrayPtrPtr); @@ -432,6 +440,8 @@ TclLookupVar( * are 1. The object part1Ptr is converted to one of localVarNameType, * tclNsVarNameType or tclParsedVarNameType and caches as much of the * lookup as it can. + * When createPart1 is 1, callers must IncrRefCount part1Ptr if they + * plan to DecrRefCount it. * *---------------------------------------------------------------------- */ @@ -460,14 +470,11 @@ TclObjLookupVar( * address of array variable. Otherwise this * is set to NULL. */ { - Tcl_Obj *part2Ptr; + Tcl_Obj *part2Ptr = NULL; Var *resPtr; if (part2) { part2Ptr = Tcl_NewStringObj(part2, -1); - Tcl_IncrRefCount(part2Ptr); - } else { - part2Ptr = NULL; } resPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr, @@ -844,6 +851,7 @@ TclObjLookupVarEx( * * Side effects: * A new hashtable entry may be created if create is 1. + * Callers must Incr varNamePtr if they plan to Decr it if create is 1. * *---------------------------------------------------------------------- */ @@ -1311,15 +1319,10 @@ Tcl_GetVar2Ex( int flags) /* OR-ed combination of TCL_GLOBAL_ONLY, and * TCL_LEAVE_ERR_MSG bits. */ { - Tcl_Obj *part1Ptr, *part2Ptr, *resPtr; + Tcl_Obj *resPtr, *part2Ptr = NULL, *part1Ptr = Tcl_NewStringObj(part1, -1); - part1Ptr = Tcl_NewStringObj(part1, -1); - Tcl_IncrRefCount(part1Ptr); if (part2) { part2Ptr = Tcl_NewStringObj(part2, -1); - Tcl_IncrRefCount(part2Ptr); - } else { - part2Ptr = NULL; } resPtr = Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags); @@ -1615,27 +1618,9 @@ Tcl_SetVar2( * TCL_APPEND_VALUE, TCL_LIST_ELEMENT, or * TCL_LEAVE_ERR_MSG. */ { - Tcl_Obj *valuePtr, *part1Ptr, *part2Ptr; - Tcl_Obj *varValuePtr; - - part1Ptr = Tcl_NewStringObj(part1, -1); - Tcl_IncrRefCount(part1Ptr); - if (part2 != NULL) { - part2Ptr = Tcl_NewStringObj(part2, -1); - Tcl_IncrRefCount(part2Ptr); - } else { - part2Ptr = NULL; - } - valuePtr = Tcl_NewStringObj(newValue, -1); - Tcl_IncrRefCount(valuePtr); + Tcl_Obj *varValuePtr = Tcl_SetVar2Ex(interp, part1, part2, + Tcl_NewStringObj(newValue, -1), flags); - varValuePtr = Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, valuePtr, flags); - - Tcl_DecrRefCount(part1Ptr); - if (part2Ptr != NULL) { - Tcl_DecrRefCount(part2Ptr); - } - Tcl_DecrRefCount(valuePtr); if (varValuePtr == NULL) { return NULL; } @@ -1694,15 +1679,12 @@ Tcl_SetVar2Ex( * TCL_APPEND_VALUE, TCL_LIST_ELEMENT or * TCL_LEAVE_ERR_MSG. */ { - Tcl_Obj *part1Ptr, *part2Ptr, *resPtr; + Tcl_Obj *resPtr, *part2Ptr = NULL, *part1Ptr = Tcl_NewStringObj(part1, -1); - part1Ptr = Tcl_NewStringObj(part1, -1); Tcl_IncrRefCount(part1Ptr); if (part2) { part2Ptr = Tcl_NewStringObj(part2, -1); Tcl_IncrRefCount(part2Ptr); - } else { - part2Ptr = NULL; } resPtr = Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, newValuePtr, flags); @@ -1735,6 +1717,7 @@ Tcl_SetVar2Ex( * Side effects: * The value of the given variable is set. If either the array or the * entry didn't exist then a new variable is created. + * Callers must Incr part1Ptr if they plan to Decr it. * *---------------------------------------------------------------------- */ @@ -2024,6 +2007,7 @@ TclPtrSetVar( * variable is created. The ref count for the returned object is _not_ * incremented to reflect the returned reference; if you want to keep a * reference to the object you must increment its ref count yourself. + * Callers must Incr part1Ptr if they plan to Decr it. * *---------------------------------------------------------------------- */ @@ -2049,8 +2033,8 @@ TclIncrObjVar2( varPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr, flags, "read", 1, 1, &arrayPtr); if (varPtr == NULL) { - Tcl_AddObjErrorInfo(interp, - "\n (reading value of variable to increment)", -1); + Tcl_AddErrorInfo(interp, + "\n (reading value of variable to increment)"); return NULL; } return TclPtrIncrObjVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, @@ -2106,8 +2090,7 @@ TclPtrIncrObjVar( * variable, or -1. Only used when part1Ptr is * NULL. */ { - register Tcl_Obj *varValuePtr, *newValuePtr = NULL; - int duplicated, code; + register Tcl_Obj *varValuePtr; if (TclIsVarInHash(varPtr)) { VarHashRefCount(varPtr)++; @@ -2121,19 +2104,33 @@ TclPtrIncrObjVar( varValuePtr = Tcl_NewIntObj(0); } if (Tcl_IsShared(varValuePtr)) { - duplicated = 1; + /* Copy on write */ varValuePtr = Tcl_DuplicateObj(varValuePtr); + + if (TCL_OK == TclIncrObj(interp, varValuePtr, incrPtr)) { + return TclPtrSetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, + varValuePtr, flags, index); + } else { + Tcl_DecrRefCount(varValuePtr); + return NULL; + } } else { - duplicated = 0; - } - code = TclIncrObj(interp, varValuePtr, incrPtr); - if (code == TCL_OK) { - newValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, part1Ptr, - part2Ptr, varValuePtr, flags, index); - } else if (duplicated) { - Tcl_DecrRefCount(varValuePtr); + /* Unshared - can Incr in place */ + if (TCL_OK == TclIncrObj(interp, varValuePtr, incrPtr)) { + + /* + * This seems dumb to write the incremeted value into the var + * after we just adjusted the value in place, but the spec for + * [incr] requires that write traces fire, and making this call + * is the way to make that happen. + */ + + return TclPtrSetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, + varValuePtr, flags, index); + } else { + return NULL; + } } - return newValuePtr; } /* @@ -2216,13 +2213,10 @@ Tcl_UnsetVar2( * TCL_LEAVE_ERR_MSG. */ { int result; - Tcl_Obj *part1Ptr, *part2Ptr = NULL; + Tcl_Obj *part2Ptr = NULL, *part1Ptr = Tcl_NewStringObj(part1, -1); - part1Ptr = Tcl_NewStringObj(part1, -1); - Tcl_IncrRefCount(part1Ptr); if (part2) { part2Ptr = Tcl_NewStringObj(part2, -1); - Tcl_IncrRefCount(part2Ptr); } /* @@ -2838,6 +2832,7 @@ Tcl_LappendObjCmd( * * Side effects: * A variable will be created if one does not already exist. + * Callers must Incr arrayNameObj if they pland to Decr it. * *---------------------------------------------------------------------- */ @@ -4219,16 +4214,16 @@ TclInitArrayCmd( Tcl_Interp *interp) /* Current interpreter. */ { static const EnsembleImplMap arrayImplMap[] = { - {"anymore", ArrayAnyMoreCmd, NULL, NULL, NULL, 0}, - {"donesearch", ArrayDoneSearchCmd, NULL, NULL, NULL, 0}, + {"anymore", ArrayAnyMoreCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, + {"donesearch", ArrayDoneSearchCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"exists", ArrayExistsCmd, TclCompileArrayExistsCmd, NULL, NULL, 0}, - {"get", ArrayGetCmd, NULL, NULL, NULL, 0}, - {"names", ArrayNamesCmd, NULL, NULL, NULL, 0}, - {"nextelement", ArrayNextElementCmd, NULL, NULL, NULL, 0}, + {"get", ArrayGetCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, + {"names", ArrayNamesCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0}, + {"nextelement", ArrayNextElementCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"set", ArraySetCmd, TclCompileArraySetCmd, NULL, NULL, 0}, - {"size", ArraySizeCmd, NULL, NULL, NULL, 0}, - {"startsearch", ArrayStartSearchCmd, NULL, NULL, NULL, 0}, - {"statistics", ArrayStatsCmd, NULL, NULL, NULL, 0}, + {"size", ArraySizeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"startsearch", ArrayStartSearchCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"statistics", ArrayStatsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"unset", ArrayUnsetCmd, TclCompileArrayUnsetCmd, NULL, NULL, 0}, {NULL, NULL, NULL, NULL, NULL, 0} }; @@ -4252,6 +4247,8 @@ TclInitArrayCmd( * The variable given by myName is linked to the variable in framePtr * given by otherP1 and otherP2, so that references to myName are * redirected to the other variable like a symbolic link. + * Callers must Incr myNamePtr if they plan to Decr it. + * Callers must Incr otherP1Ptr if they plan to Decr it. * *---------------------------------------------------------------------- */ @@ -4360,14 +4357,12 @@ TclPtrMakeUpvar( int index) /* If the variable to be linked is an indexed * scalar, this is its index. Otherwise, -1 */ { - Tcl_Obj *myNamePtr; + Tcl_Obj *myNamePtr = NULL; int result; if (myName) { myNamePtr = Tcl_NewStringObj(myName, -1); Tcl_IncrRefCount(myNamePtr); - } else { - myNamePtr = NULL; } result = TclPtrObjMakeUpvar(interp, otherPtr, myNamePtr, myFlags, index); if (myNamePtr) { @@ -4376,6 +4371,8 @@ TclPtrMakeUpvar( return result; } +/* Callers must Incr myNamePtr if they plan to Decr it. */ + int TclPtrObjMakeUpvar( Tcl_Interp *interp, /* Interpreter containing variables. Used for @@ -5239,8 +5236,6 @@ TclDeleteNamespaceVars( for (varPtr = VarHashFirstVar(tablePtr, &search); varPtr != NULL; varPtr = VarHashFirstVar(tablePtr, &search)) { Tcl_Obj *objPtr = Tcl_NewObj(); - - Tcl_IncrRefCount(objPtr); VarHashRefCount(varPtr)++; /* Make sure we get to remove from * hash. */ Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, objPtr); @@ -5504,15 +5499,10 @@ TclVarErrMsg( * e.g. "read", "set", or "unset". */ const char *reason) /* String describing why operation failed. */ { - Tcl_Obj *part1Ptr = NULL, *part2Ptr = NULL; + Tcl_Obj *part2Ptr = NULL, *part1Ptr = Tcl_NewStringObj(part1, -1); - part1Ptr = Tcl_NewStringObj(part1, -1); - Tcl_IncrRefCount(part1Ptr); if (part2) { part2Ptr = Tcl_NewStringObj(part2, -1); - Tcl_IncrRefCount(part2Ptr); - } else { - part2 = NULL; } TclObjVarErrMsg(interp, part1Ptr, part2Ptr, operation, reason, -1); @@ -5785,7 +5775,6 @@ Tcl_FindNamespaceVar( Tcl_Obj *namePtr = Tcl_NewStringObj(name, -1); Tcl_Var var; - Tcl_IncrRefCount(namePtr); var = ObjFindNamespaceVar(interp, namePtr, contextNsPtr, flags); Tcl_DecrRefCount(namePtr); return var; @@ -5880,7 +5869,6 @@ ObjFindNamespaceVar( varPtr = NULL; if (simpleName != name) { simpleNamePtr = Tcl_NewStringObj(simpleName, -1); - Tcl_IncrRefCount(simpleNamePtr); } else { simpleNamePtr = namePtr; } diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 8fbe049..47091de 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -507,7 +507,7 @@ GenerateHeader( * ExtractHeader -- * * Take the values out of a gzip header and store them in a dictionary. - * SetValue is a helper function. + * SetValue is a helper macro. * * Results: * None. @@ -518,18 +518,8 @@ GenerateHeader( *---------------------------------------------------------------------- */ -static inline void -SetValue( - Tcl_Obj *dictObj, - const char *key, - Tcl_Obj *value) -{ - Tcl_Obj *keyObj = Tcl_NewStringObj(key, -1); - - Tcl_IncrRefCount(keyObj); - Tcl_DictObjPut(NULL, dictObj, keyObj, value); - TclDecrRefCount(keyObj); -} +#define SetValue(dictObj, key, value) \ + Tcl_DictObjPut(NULL, (dictObj), Tcl_NewStringObj((key), -1), (value)) static void ExtractHeader( @@ -2119,9 +2109,6 @@ ZlibCmd( } if (headerVarObj != NULL && Tcl_ObjSetVar2(interp, headerVarObj, NULL, headerDictObj, TCL_LEAVE_ERR_MSG) == NULL) { - if (headerDictObj) { - TclDecrRefCount(headerDictObj); - } return TCL_ERROR; } return TCL_OK; @@ -3878,7 +3865,7 @@ TclZlibInit( cfg[0].key = "zlibVersion"; cfg[0].value = zlibVersion(); cfg[1].key = NULL; - Tcl_RegisterConfig(interp, "zlib", cfg, "ascii"); + Tcl_RegisterConfig(interp, "zlib", cfg, "iso8859-1"); /* * Formally provide the package as a Tcl built-in. diff --git a/library/http/http.tcl b/library/http/http.tcl index c3290c9..98066af 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -11,7 +11,7 @@ package require Tcl 8.6- # Keep this in sync with pkgIndex.tcl and with the install directories in # Makefiles -package provide http 2.8.5 +package provide http 2.8.6 namespace eval http { # Allow resourcing to not clobber existing data @@ -537,11 +537,10 @@ proc http::geturl {url args} { # If a timeout is specified we set up the after event and arrange for an # asynchronous socket connection. - set sockopts [list] + set sockopts [list -async] if {$state(-timeout) > 0} { set state(after) [after $state(-timeout) \ [list http::reset $token timeout]] - lappend sockopts -async } # If we are using the proxy, we must pass in the full URL that includes @@ -597,10 +596,15 @@ proc http::geturl {url args} { set socketmap($state(socketinfo)) $sock } - # Wait for the connection to complete. + if {![info exists phost]} { + set phost "" + } + fileevent $sock writable [list http::Connect $token $proto $phost $srvurl] - if {$state(-timeout) > 0} { - fileevent $sock writable [list http::Connect $token] + # Wait for the connection to complete. + if {![info exists state(-command)]} { + # geturl does EVERYTHING asynchronously, so if the user + # calls it synchronously, we just do a wait here. http::wait $token if {![info exists state]} { @@ -616,13 +620,29 @@ proc http::geturl {url args} { set err [lindex $state(error) 0] cleanup $token return -code error $err - } elseif {$state(status) ne "connect"} { - # Likely to be connection timeout - return $token } - set state(status) "" } + return $token +} + + +proc http::Connected { token proto phost srvurl} { + variable http + variable urlTypes + + variable $token + upvar 0 $token state + + # Set back the variables needed here + set sock $state(sock) + set isQueryChannel [info exists state(-querychannel)] + set isQuery [info exists state(-query)] + set host [lindex [split $state(socketinfo) :] 0] + set port [lindex [split $state(socketinfo) :] 1] + + set defport [lindex $urlTypes($proto) 0] + # Send data in cr-lf format, but accept any line terminators fconfigure $sock -translation {auto crlf} -buffersize $state(-blocksize) @@ -753,35 +773,17 @@ proc http::geturl {url args} { fileevent $sock readable [list http::Event $sock $token] } - if {![info exists state(-command)]} { - # geturl does EVERYTHING asynchronously, so if the user calls it - # synchronously, we just do a wait here. - - wait $token - if {$state(status) eq "error"} { - # Something went wrong, so throw the exception, and the - # enclosing catch will do cleanup. - return -code error [lindex $state(error) 0] - } - } } err]} { # The socket probably was never connected, or the connection dropped # later. - # Clean up after events and such, but DON'T call the command callback - # (if available) because we're going to throw an exception from here - # instead. - # if state(status) is error, it means someone's already called Finish # to do the above-described clean up. if {$state(status) ne "error"} { - Finish $token $err 1 + Finish $token $err } - cleanup $token - return -code error $err } - return $token } # Data access functions: @@ -865,7 +867,7 @@ proc http::cleanup {token} { # Sets the status of the connection, which unblocks # the waiting geturl call -proc http::Connect {token} { +proc http::Connect {token proto phost srvurl} { variable $token upvar 0 $token state set err "due to unexpected EOF" @@ -873,10 +875,10 @@ proc http::Connect {token} { [eof $state(sock)] || [set err [fconfigure $state(sock) -error]] ne "" } { - Finish $token "connect failed $err" 1 + Finish $token "connect failed $err" } else { - set state(status) connect fileevent $state(sock) writable {} + ::http::Connected $token $proto $phost $srvurl } return } @@ -981,7 +983,7 @@ proc http::Event {sock token} { } elseif {$n == 0} { # We have now read all headers # We ignore HTTP/1.1 100 Continue returns. RFC2616 sec 8.2.3 - if {$state(http) == "" || [lindex $state(http) 1] == 100} { + if {$state(http) == "" || ([regexp {^\S+\s(\d+)} $state(http) {} x] && $x == 100)} { return } @@ -1379,7 +1381,7 @@ proc http::mapReply {string} { } set converted [string map $formMap $string] if {[string match "*\[\u0100-\uffff\]*" $converted]} { - regexp {[\u0100-\uffff]} $converted badChar + regexp "\[\u0100-\uffff\]" $converted badChar # Return this error message for maximum compatability... :^/ return -code error \ "can't read \"formMap($badChar)\": no such element in array" diff --git a/library/http/pkgIndex.tcl b/library/http/pkgIndex.tcl index 828c860..e4c0e11 100644 --- a/library/http/pkgIndex.tcl +++ b/library/http/pkgIndex.tcl @@ -1,2 +1,2 @@ if {![package vsatisfies [package provide Tcl] 8.6-]} {return} -package ifneeded http 2.8.5 [list tclPkgSetup $dir http 2.8.5 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}] +package ifneeded http 2.8.6 [list tclPkgSetup $dir http 2.8.6 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}] diff --git a/macosx/tclMacOSXFCmd.c b/macosx/tclMacOSXFCmd.c index f266443..6016c6d 100644 --- a/macosx/tclMacOSXFCmd.c +++ b/macosx/tclMacOSXFCmd.c @@ -10,6 +10,7 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ +#include <sys/stat.h> #include "tclInt.h" #ifdef HAVE_GETATTRLIST diff --git a/pkgs/package.list.txt b/pkgs/package.list.txt index f12111d..a13b0fb 100644 --- a/pkgs/package.list.txt +++ b/pkgs/package.list.txt @@ -23,4 +23,4 @@ TDBC TDBC tdbcmysql tdbc::mysql tdbcodbc tdbc::odbc tdbcpostgres tdbc::postgres -tdbcsqlite3- tdbc::sqlite3 +tdbcsqlite3 tdbc::sqlite3 diff --git a/tests/chan.test b/tests/chan.test index da44ffd..d8390e2 100644 --- a/tests/chan.test +++ b/tests/chan.test @@ -61,7 +61,7 @@ test chan-4.5 {chan command: check valid inValue, invalid outValue} -body { } -returnCodes error -match glob -result {bad value for -eofchar:*} test chan-4.6 {chan command: check no inValue, valid outValue} -body { chan configure stdout -eofchar [list {} \x27] -} -returnCodes ok -result {} +} -returnCodes ok -result {} -cleanup {chan configure stdout -eofchar [list {} {}]} test chan-5.1 {chan command: copy subcommand} -body { chan copy foo diff --git a/tests/cmdAH.test b/tests/cmdAH.test index 3011597..0517e5f 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -68,6 +68,12 @@ test cmdAH-1.2 {Tcl_CatchObjCmd, errors} { test cmdAH-1.3 {Tcl_CatchObjCmd, errors} -returnCodes error -body { catch foo bar baz spaz } -result {wrong # args: should be "catch script ?resultVarName? ?optionVarName?"} +test cmdAH-1.4 {Bug 3595576} { + catch {catch {} -> noSuchNs::var} +} 1 +test cmdAH-1.5 {Bug 3595576} { + catch {catch error -> noSuchNs::var} +} 1 test cmdAH-2.1 {Tcl_CdObjCmd} -returnCodes error -body { cd foo bar diff --git a/tests/env.test b/tests/env.test index 9010f52..e75d517 100644 --- a/tests/env.test +++ b/tests/env.test @@ -70,7 +70,7 @@ set printenvScript [makeFile { } proc mangle s { regsub -all {\[|\\|\]} $s {\\&} s - regsub -all {[\u0000-\u001f\u007f-\uffff]} $s {[manglechar &]} s + regsub -all "\[\u0000-\u001f\u007f-\uffff\]" $s {[manglechar &]} s return [subst -novariables $s] } proc manglechar c { diff --git a/tests/exec.test b/tests/exec.test index 64d3517..871c0c5 100644 --- a/tests/exec.test +++ b/tests/exec.test @@ -157,7 +157,7 @@ test exec-2.6 {redirecting input from immediate source, with UTF} -setup { encoding system iso8859-1 proc quotenonascii s { regsub -all {\[|\\|\]} $s {\\&} s - regsub -all {[\u007f-\uffff]} $s \ + regsub -all "\[\u007f-\uffff\]" $s \ {[apply {c {format {\u%04x} [scan $c %c]}} &]} s return [subst -novariables $s] } diff --git a/tests/http.test b/tests/http.test index 9861e0e..e2de7d8 100644 --- a/tests/http.test +++ b/tests/http.test @@ -547,11 +547,10 @@ test http-4.14 {http::Event} -body { error "bogus return from http::geturl" } http::wait $token - http::status $token - # error code varies among platforms. -} -returnCodes 1 -match regexp -cleanup { + lindex [http::error $token] 0 +} -cleanup { catch {http::cleanup $token} -} -result {(connect failed|couldn't open socket)} +} -result {connect failed connection refused} # Bogus host test http-4.15 {http::Event} -body { # This test may fail if you use a proxy server. That is to be diff --git a/tests/info.test b/tests/info.test index 5078e11..ebc853a 100644 --- a/tests/info.test +++ b/tests/info.test @@ -692,31 +692,31 @@ test info-21.5 {miscellaneous error conditions} -returnCodes error -body { ## # ### ### ### ######### ######### ######### ## info frame + ## Helper # For the more complex results we cut the file name down to remove path # dependencies, and we use only part of the first line of the reported # command. The latter is required because otherwise the whole test case may # appear in some results, but the result is part of the testcase. An infinite # string would be required to describe that. The cutting-down breaks this. + proc reduce {frame} { - set pos [lsearch -exact $frame cmd] - incr pos - set cmd [lindex $frame $pos] + set cmd [dict get $frame cmd] if {[regexp \n $cmd]} { - set first [string range [lindex [split $cmd \n] 0] 0 end-4] - set frame [lreplace $frame $pos $pos $first] + dict set frame cmd \ + [string range [lindex [split $cmd \n] 0] 0 end-4] } - set pos [lsearch -exact $frame file] - if {$pos >=0} { - incr pos - set tail [file tail [lindex $frame $pos]] - set frame [lreplace $frame $pos $pos $tail] + if {[dict exists $frame file]} { + dict set frame file \ + [file tail [dict get $frame file]] } - set frame + return $frame } + proc subinterp {} { interp create sub ; interp debug sub -frame 1; interp eval sub [list proc reduce [info args reduce] [info body reduce]] } + ## Helper # Generate a stacktrace from the current location to top. This code # not only depends on the exact location of things, but also on the @@ -1454,9 +1454,9 @@ test info-30.1 {bs+nl in literal words, procedure body, compiled} -body { test info-30.2 {bs+nl in literal words, namespace script} { namespace eval xxx { variable res \ - [reduce [info frame 0]];# line 1457 + [info frame 0];# line 1457 } - return $xxx::res + return [reduce $xxx::res] } {type source line 1457 file info.test cmd {info frame 0} level 0} test info-30.3 {bs+nl in literal words, namespace multi-word script} { diff --git a/tests/listObj.test b/tests/listObj.test index 8b24aa9..937fb1d 100644 --- a/tests/listObj.test +++ b/tests/listObj.test @@ -196,6 +196,10 @@ test listobj-10.1 {Bug [2971669]} {*}{ -result {{a b c d e} {} {a b c d e f}} } +test listobj-11.1 {bug 3598580} { + testobj bug3598580 +} 123 + # cleanup ::tcltest::cleanupTests return diff --git a/tests/load.test b/tests/load.test index eef677f..cded85d 100644 --- a/tests/load.test +++ b/tests/load.test @@ -188,7 +188,7 @@ test load-8.3 {TclGetLoadedPackages procedure} [list teststaticpkg $dll $loaded] test load-8.4 {TclGetLoadedPackages procedure} [list $dll $loaded teststaticpkg] { load [file join $testDir pkgb$ext] pkgb list [info loaded {}] [lsort [info commands pkgb_*]] -} [list [concat [list [list [file join $testDir pkgb$ext] Pkgb] {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga]] $alreadyLoaded] {pkgb_sub pkgb_unsafe}] +} [list [concat [list [list [file join $testDir pkgb$ext] Pkgb] {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga]] $alreadyLoaded] {pkgb_demo pkgb_sub pkgb_unsafe}] interp delete child test load-9.1 {Tcl_StaticPackage, load already-loaded package into another interp} \ diff --git a/tests/nre.test b/tests/nre.test index b8ef2e0..b5eb032 100644 --- a/tests/nre.test +++ b/tests/nre.test @@ -74,7 +74,6 @@ test nre-1.1 {self-recursive procs} -setup { } -constraints { testnrelevels } -result {{0 1 1 1} 0} - test nre-1.2 {self-recursive lambdas} -setup { set a [list i [makebody {apply $::a $i}]] } -body { @@ -85,7 +84,6 @@ test nre-1.2 {self-recursive lambdas} -setup { } -constraints { testnrelevels } -result {{0 1 1 1} 0} - test nre-1.3 {mutually recursive procs and lambdas} -setup { proc a i { apply $::b [incr i] @@ -164,8 +162,7 @@ test nre-5.1 {[namespace eval] is not recursive} -setup { namespace delete ::foo } -constraints { testnrelevels -} -result {{0 3 2 2} 0} - +} -result {{0 2 2 2} 0} test nre-5.2 {[namespace eval] is not recursive} -setup { namespace eval ::foo { setabs @@ -177,7 +174,7 @@ test nre-5.2 {[namespace eval] is not recursive} -setup { namespace delete ::foo } -constraints { testnrelevels -} -result {{0 3 2 2} 0} +} -result {{0 2 2 2} 0} test nre-6.1 {[uplevel] is not recursive} -setup { proc a i [makebody {uplevel 1 [list a $i]}] @@ -189,7 +186,6 @@ test nre-6.1 {[uplevel] is not recursive} -setup { } -constraints { testnrelevels } -result {{0 2 2 0} 0} - test nre-6.2 {[uplevel] is not recursive} -setup { setabs proc a i [makebody {uplevel 1 "set x $i; a $i"}] @@ -211,7 +207,6 @@ test nre-7.1 {[catch] is not recursive} -setup { } -constraints { testnrelevels } -result {{0 3 3 0} 0} - test nre-7.2 {[if] is not recursive} -setup { setabs proc a i [makebody {uplevel 1 "if 1 {a $i}"}] @@ -222,7 +217,6 @@ test nre-7.2 {[if] is not recursive} -setup { } -constraints { testnrelevels } -result {{0 2 2 0} 0} - test nre-7.3 {[while] is not recursive} -setup { setabs proc a i [makebody {uplevel 1 "while 1 {set res \[a $i\]; break}; set res"}] @@ -233,7 +227,6 @@ test nre-7.3 {[while] is not recursive} -setup { } -constraints { testnrelevels } -result {{0 2 2 0} 0} - test nre-7.4 {[for] is not recursive} -setup { setabs proc a i [makebody {uplevel 1 "for {set j 0} {\$j < 10} {incr j} {set res \[a $i\]; break}; set res"}] @@ -244,7 +237,6 @@ test nre-7.4 {[for] is not recursive} -setup { } -constraints { testnrelevels } -result {{0 2 2 0} 0} - test nre-7.5 {[foreach] is not recursive} -setup { # # Enable once [foreach] is NR-enabled @@ -258,7 +250,6 @@ test nre-7.5 {[foreach] is not recursive} -setup { } -constraints { testnrelevels } -result {{0 3 3 0} 0} - test nre-7.6 {[eval] is not recursive} -setup { proc a i [makebody {eval [list a $i]}] } -body { @@ -269,7 +260,6 @@ test nre-7.6 {[eval] is not recursive} -setup { } -constraints { testnrelevels } -result {{0 2 2 1} 0} - test nre-7.7 {[eval] is not recursive} -setup { proc a i [makebody {eval "a $i"}] } -body { @@ -280,7 +270,6 @@ test nre-7.7 {[eval] is not recursive} -setup { } -constraints { testnrelevels } -result {{0 2 2 1} 0} - test nre-7.8 {bug #2910748: switch out of stale BC is not nre-aware} -setup { proc foo args {} foo @@ -295,18 +284,15 @@ test nre-7.8 {bug #2910748: switch out of stale BC is not nre-aware} -setup { } -body { # if switching to plain eval is not nre aware, this will cause a "cannot # yield" error - list [bar] [bar] [bar] } -cleanup { rename bar {} rename foo {} } -result {1 2 3} - test nre-8.1 {nre and {*}} -body { # force an expansion that grows the evaluation stack, check that nre # adapts the TEBCdataPtr. This crashes on failure. - proc inner {} { set long [lrepeat 1000000 1] list {*}$long @@ -321,21 +307,18 @@ test nre-8.2 {nre and {*}, [Bug 2415422]} -body { # force an expansion that grows the evaluation stack, check that nre # adapts the bcFramePtr. This causes an NRE assertion to fail if it is not # done properly. - proc nop {} {} proc crash {} { foreach val [list {*}[lrepeat 100000 x]] { nop } } - crash } -cleanup { rename nop {} rename crash {} } - # # Basic TclOO tests # @@ -351,7 +334,6 @@ test nre-oo.1 {really deep calls in oo - direct} -setup { } -constraints { testnrelevels } -result {{0 1 1 1} 0} - test nre-oo.2 {really deep calls in oo - call via [self]} -setup { oo::object create foo oo::objdefine foo method bar i [makebody {[self] bar $i}] @@ -363,7 +345,6 @@ test nre-oo.2 {really deep calls in oo - call via [self]} -setup { } -constraints { testnrelevels } -result {{0 1 1 1} 0} - test nre-oo.3 {really deep calls in oo - private calls} -setup { oo::object create foo oo::objdefine foo method bar i [makebody {my bar $i}] @@ -375,7 +356,6 @@ test nre-oo.3 {really deep calls in oo - private calls} -setup { } -constraints { testnrelevels } -result {{0 1 1 1} 0} - test nre-oo.4 {really deep calls in oo - overriding} -setup { oo::class create foo { method bar i [makebody {my bar $i}] @@ -392,7 +372,6 @@ test nre-oo.4 {really deep calls in oo - overriding} -setup { } -constraints { testnrelevels } -result {{0 1 1 1} 0} - test nre-oo.5 {really deep calls in oo - forwards} -setup { oo::object create foo set body [makebody {my boo $i}] @@ -409,7 +388,6 @@ test nre-oo.5 {really deep calls in oo - forwards} -setup { testnrelevels } -result {{0 2 1 1} 0} - # # NASTY BUG found by tcllib's interp package # diff --git a/tests/oo.test b/tests/oo.test index 540cdf3..5d34077 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -7,7 +7,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require -exact TclOO 0.7 ;# Must match value in generic/tclOO.h +package require TclOO 1.0 package require tcltest 2 if {"::tcltest" in [namespace children]} { namespace import -force ::tcltest::* diff --git a/tests/ooNext2.test b/tests/ooNext2.test index e78e0d0..d77e8d1 100644 --- a/tests/ooNext2.test +++ b/tests/ooNext2.test @@ -7,7 +7,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require -exact TclOO 0.7 ;# Must match value in configure.in +package require TclOO 1.0 package require tcltest 2 if {"::tcltest" in [namespace children]} { namespace import -force ::tcltest::* diff --git a/tests/parse.test b/tests/parse.test index 0f76d64..bc4107d 100644 --- a/tests/parse.test +++ b/tests/parse.test @@ -26,6 +26,7 @@ testConstraint testparsevarname [llength [info commands testparsevarname]] testConstraint testparsevar [llength [info commands testparsevar]] testConstraint testasync [llength [info commands testasync]] testConstraint testcmdtrace [llength [info commands testcmdtrace]] +testConstraint testevent [llength [info commands testevent]] test parse-1.1 {Tcl_ParseCommand procedure, computing string length} testparser { testparser [bytestring "foo\0 bar"] -1 @@ -1090,6 +1091,14 @@ test parse-20.12 {TclParseBackslash: truncated escape} testparser { testparser {\x12X} 5 } {- {\x12X} 1 word {\x12X} 2 backslash {\x12} 0 text X 0 {}} +test parse-21.0 {Bug 1884496} testevent { + set ::script {set a [p]; return -level 0 $a} + proc ::p {} {string first s $::script} + testevent queue a head $::script + update +} {} + + cleanupTests } diff --git a/tests/zlib.test b/tests/zlib.test index 5f1e5fc..891dba0 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -826,6 +826,20 @@ test zlib-11.2 "Bug #3390073: mis-appled gzip filtering" -setup { } -cleanup { removeFile $file } -result {1000 /foo/bar 0} +test zlib-11.3 {Bug 3595576 variant} -setup { + set file [makeFile {} test.input] +} -constraints zlib -body { + set f [open $file wb] + puts -nonewline [zlib push gzip $f -header {filename /foo/bar}] \ + [string repeat "hello" 1000] + close $f + set f [open $file rb] + set d [read $f] + close $f + zlib gunzip $d -header noSuchNs::foo +} -cleanup { + removeFile $file +} -returnCodes error -result {can't set "noSuchNs::foo": parent namespace doesn't exist} ::tcltest::cleanupTests return diff --git a/tools/tcltk-man2html.tcl b/tools/tcltk-man2html.tcl index b4c0f6c..f87f701 100755 --- a/tools/tcltk-man2html.tcl +++ b/tools/tcltk-man2html.tcl @@ -1,6 +1,12 @@ #!/usr/bin/env tclsh -package require Tcl 8.6- +if {[catch {package require Tcl 8.6-} msg]} { + puts stderr "ERROR: $msg" + puts stderr "If running this script from 'make html', set the\ + NATIVE_TCLSH environment\nvariable to point to an installed\ + tclsh8.6 (or the equivalent tclsh86.exe\non Windows)." + exit 1 +} # Convert Ousterhout format man pages into highly crosslinked hypertext. # @@ -16,7 +22,7 @@ package require Tcl 8.6- # Copyright (c) 1995-1997 Roger E. Critchlow Jr # Copyright (c) 2004-2010 Donal K. Fellows -regexp {\d+\.\d+} {$Revision: 1.49 $} ::Version +set ::Version "50/8.6" set ::CSSFILE "docs.css" ## @@ -454,17 +460,16 @@ proc plus-pkgs {type args} { } if {!$build_tcl} return set result {} - foreach {dir name} $args { - set globpat $tcltkdir/$tcldir/pkgs/$dir*/doc/*.$type - if {![llength [glob -nocomplain $globpat]]} { + set pkgsdir $tcltkdir/$tcldir/pkgs + foreach {dir name version} $args { + set globpat $pkgsdir/$dir/doc/*.$type + if {![llength [glob -type f -nocomplain $globpat]]} { # Fallback for manpages generated using doctools - set globpat $tcltkdir/$tcldir/pkgs/$dir*/doc/man/*.$type - if {![llength [glob -nocomplain $globpat]]} { + set globpat $pkgsdir/$dir/doc/man/*.$type + if {![llength [glob -type f -nocomplain $globpat]]} { continue } } - regexp "pkgs/${dir}(.*)/doc$" [glob $tcltkdir/$tcldir/pkgs/$dir*/doc] \ - -> version switch $type { n { set title "$name Package Commands" @@ -642,6 +647,42 @@ try { append appdir "$tkdir" } + + # When building docs for Tcl, try to build docs for bundled packages too + set packageBuildList {} + if {$build_tcl} { + set pkgsDir [file join $tcltkdir $tcldir pkgs] + set subdirs [glob -nocomplain -types d -tails -directory $pkgsDir *] + + foreach dir [lsort $subdirs] { + # Parse the subdir name into (name, version) as fallback... + set description [split $dir -] + if {2 != [llength $description]} { + regexp {([^0-9]*)(.*)} $dir -> n v + set description [list $n $v] + } + + # ... but try to extract (name, version) from subdir contents + try { + set f [open [file join $pkgsDir $dir configure.in]] + foreach line [split [read $f] \n] { + if {2 == [scan $line \ + { AC_INIT ( [%[^]]] , [%[^]]] ) } n v]} { + set description [list $n $v] + break + } + } + } finally { + catch {close $f; unset f} + } + + if {[file exists [file join $pkgsDir $dir configure]]} { + # Looks like a package, record our best extraction attempt + lappend packageBuildList $dir {*}$description + } + } + } + # Get the list of packages to try, and what their human-readable names # are. Note that the package directory list should be version-less. try { @@ -666,6 +707,14 @@ try { } } + # Convert to human readable names, if applicable + for {set idx 0} {$idx < [llength $packageBuildList]} {incr idx 3} { + lassign [lrange $packageBuildList $idx $idx+2] d n v + if {[dict exists $packageDirNameMap $n]} { + lset packageBuildList $idx+1 [dict get $packageDirNameMap $n] + } + } + # # Invoke the scraper/converter engine. # @@ -676,12 +725,12 @@ try { "The commands which the <B>tclsh</B> interpreter implements."] \ [plus-base $build_tk $tkdir doc/*.n {Tk Commands} TkCmd \ "The additional commands which the <B>wish</B> interpreter implements."] \ - {*}[plus-pkgs n {*}$packageDirNameMap] \ + {*}[plus-pkgs n {*}$packageBuildList] \ [plus-base $build_tcl $tcldir doc/*.3 {Tcl C API} TclLib \ "The C functions which a Tcl extended C program may use."] \ [plus-base $build_tk $tkdir doc/*.3 {Tk C API} TkLib \ "The additional C functions which a Tk extended C program may use."] \ - {*}[plus-pkgs 3 {*}$packageDirNameMap] + {*}[plus-pkgs 3 {*}$packageBuildList] } on error {msg opts} { # On failure make sure we show what went wrong. We're not supposed # to get here though; it represents a bug in the script. diff --git a/unix/Makefile.in b/unix/Makefile.in index df05759..f8dd67c 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -839,8 +839,8 @@ install-libraries: libraries do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/http1.0; \ done; - @echo "Installing package http 2.8.5 as a Tcl Module"; - @$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.6/http-2.8.5.tm; + @echo "Installing package http 2.8.6 as a Tcl Module"; + @$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.6/http-2.8.6.tm; @echo "Installing package opt0.4 files to $(SCRIPT_INSTALL_DIR)/opt0.4/"; @for i in $(TOP_DIR)/library/opt/*.tcl ; \ do \ @@ -1718,7 +1718,7 @@ install-packages: packages fi; \ done -test-packages: tcltest packages +test-packages: ${TCLTEST_EXE} packages @for i in $(PKGS_DIR)/*; do \ if [ -d $$i ]; then \ pkg=`basename $$i`; \ diff --git a/unix/dltest/pkgb.c b/unix/dltest/pkgb.c index 71b42e1..b32092c 100644 --- a/unix/dltest/pkgb.c +++ b/unix/dltest/pkgb.c @@ -21,6 +21,8 @@ static int Pkgb_SubObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int Pkgb_UnsafeObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +static int Pkgb_DemoObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* *---------------------------------------------------------------------- @@ -39,6 +41,10 @@ static int Pkgb_UnsafeObjCmd(ClientData clientData, *---------------------------------------------------------------------- */ +#ifndef Tcl_GetErrorLine +# define Tcl_GetErrorLine(interp) ((interp)->errorLine) +#endif + static int Pkgb_SubObjCmd( ClientData dummy, /* Not used. */ @@ -54,6 +60,9 @@ Pkgb_SubObjCmd( } if ((Tcl_GetIntFromObj(interp, objv[1], &first) != TCL_OK) || (Tcl_GetIntFromObj(interp, objv[2], &second) != TCL_OK)) { + char buf[TCL_INTEGER_SPACE]; + sprintf(buf, "%d", Tcl_GetErrorLine(interp)); + Tcl_AppendResult(interp, " in line: ", buf, NULL); return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewIntObj(first - second)); @@ -84,7 +93,26 @@ Pkgb_UnsafeObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_SetObjResult(interp, Tcl_NewStringObj("unsafe command invoked", -1)); + return Tcl_EvalEx(interp, "list unsafe command invoked", -1, TCL_EVAL_GLOBAL); +} + +static int +Pkgb_DemoObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ +#if (TCL_MAJOR_VERSION > 8) || (TCL_MINOR_VERSION > 4) + Tcl_Obj *first; + + if (Tcl_ListObjIndex(NULL, Tcl_GetEncodingSearchPath(), 0, &first) + == TCL_OK) { + Tcl_SetObjResult(interp, first); + } +#else + Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_GetDefaultEncodingDir(), -1)); +#endif return TCL_OK; } @@ -112,16 +140,16 @@ Pkgb_Init( { int code; - if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) { + if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) { return TCL_ERROR; } - code = Tcl_PkgProvide(interp, "Pkgb", "2.3"); + code = Tcl_PkgProvideEx(interp, "Pkgb", "2.3", NULL); if (code != TCL_OK) { return code; } Tcl_CreateObjCommand(interp, "pkgb_sub", Pkgb_SubObjCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "pkgb_unsafe", Pkgb_UnsafeObjCmd, NULL, - NULL); + Tcl_CreateObjCommand(interp, "pkgb_unsafe", Pkgb_UnsafeObjCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "pkgb_demo", Pkgb_DemoObjCmd, NULL, NULL); return TCL_OK; } @@ -149,10 +177,10 @@ Pkgb_SafeInit( { int code; - if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) { + if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) { return TCL_ERROR; } - code = Tcl_PkgProvide(interp, "Pkgb", "2.3"); + code = Tcl_PkgProvideEx(interp, "Pkgb", "2.3", NULL); if (code != TCL_OK) { return code; } diff --git a/unix/tclUnixCompat.c b/unix/tclUnixCompat.c index e201018..2a68f7f 100644 --- a/unix/tclUnixCompat.c +++ b/unix/tclUnixCompat.c @@ -995,12 +995,19 @@ TclWinCPUID( /* See: <http://en.wikipedia.org/wiki/CPUID> */ #if defined(HAVE_CPUID) - __asm__ __volatile__("mov %%ebx, %%edi \n\t" /* save %ebx */ +#if defined(__x86_64__) || defined(_M_AMD64) || defined (_M_X64) + __asm__ __volatile__("movq %%rbx, %%rsi \n\t" /* save %rbx */ "cpuid \n\t" - "mov %%ebx, %%esi \n\t" /* save what cpuid just put in %ebx */ - "mov %%edi, %%ebx \n\t" /* restore the old %ebx */ + "xchgq %%rsi, %%rbx \n\t" /* restore the old %rbx */ : "=a"(regsPtr[0]), "=S"(regsPtr[1]), "=c"(regsPtr[2]), "=d"(regsPtr[3]) - : "a"(index) : "edi"); + : "a"(index)); +#else + __asm__ __volatile__("mov %%ebx, %%esi \n\t" /* save %ebx */ + "cpuid \n\t" + "xchg %%esi, %%ebx \n\t" /* restore the old %ebx */ + : "=a"(regsPtr[0]), "=S"(regsPtr[1]), "=c"(regsPtr[2]), "=d"(regsPtr[3]) + : "a"(index)); +#endif status = TCL_OK; #endif return status; diff --git a/unix/tclUnixFCmd.c b/unix/tclUnixFCmd.c index 559992f..2b6f3f3 100644 --- a/unix/tclUnixFCmd.c +++ b/unix/tclUnixFCmd.c @@ -40,6 +40,7 @@ * DAMAGE. */ +#include <sys/stat.h> #include "tclInt.h" #include <utime.h> #include <grp.h> @@ -244,7 +245,7 @@ MODULE_SCOPE long tclMacOSXDarwinRelease; #endif /* NO_REALPATH */ #ifdef HAVE_FTS -#ifdef HAVE_STRUCT_STAT64 +#if defined(HAVE_STRUCT_STAT64) && !defined(__APPLE__) /* fts doesn't do stat64 */ # define noFtsStat 1 #elif defined(__APPLE__) && defined(__LP64__) && \ diff --git a/unix/tclUnixFile.c b/unix/tclUnixFile.c index 38504d9..5816b01 100644 --- a/unix/tclUnixFile.c +++ b/unix/tclUnixFile.c @@ -10,6 +10,7 @@ * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ +#include <sys/stat.h> #include "tclInt.h" #include "tclFileSystem.h" @@ -1181,9 +1182,10 @@ TclpUtime( int TclOSstat( const char *name, - Tcl_StatBuf *statBuf) + void *cygstat) { struct stat buf; + Tcl_StatBuf *statBuf = cygstat; int result = stat(name, &buf); statBuf->st_mode = buf.st_mode; @@ -1203,9 +1205,10 @@ TclOSstat( int TclOSlstat( const char *name, - Tcl_StatBuf *statBuf) + void *cygstat) { struct stat buf; + Tcl_StatBuf *statBuf = cygstat; int result = lstat(name, &buf); statBuf->st_mode = buf.st_mode; diff --git a/unix/tclUnixInit.c b/unix/tclUnixInit.c index f07b123..6653e4b 100644 --- a/unix/tclUnixInit.c +++ b/unix/tclUnixInit.c @@ -8,6 +8,7 @@ * All rights reserved. */ +#include <sys/stat.h> #include "tclInt.h" #include <stddef.h> #include <locale.h> diff --git a/unix/tclUnixPort.h b/unix/tclUnixPort.h index 63c500d..59a35ba 100644 --- a/unix/tclUnixPort.h +++ b/unix/tclUnixPort.h @@ -21,10 +21,6 @@ #ifndef _TCLUNIXPORT #define _TCLUNIXPORT - -#ifndef MODULE_SCOPE -#define MODULE_SCOPE extern -#endif /* *--------------------------------------------------------------------------- @@ -89,26 +85,26 @@ typedef off_t Tcl_SeekOffset; # define SOCKET unsigned int # define WSAEWOULDBLOCK 10035 typedef unsigned short WCHAR; - DLLIMPORT extern __stdcall int GetModuleHandleExW(unsigned int, const char *, void *); - DLLIMPORT extern __stdcall int GetModuleFileNameW(void *, const char *, int); - DLLIMPORT extern __stdcall int WideCharToMultiByte(int, int, const char *, int, + __declspec(dllimport) extern __stdcall int GetModuleHandleExW(unsigned int, const char *, void *); + __declspec(dllimport) extern __stdcall int GetModuleFileNameW(void *, const char *, int); + __declspec(dllimport) extern __stdcall int WideCharToMultiByte(int, int, const char *, int, const char *, int, const char *, const char *); - DLLIMPORT extern __stdcall int MultiByteToWideChar(int, int, const char *, int, + __declspec(dllimport) extern __stdcall int MultiByteToWideChar(int, int, const char *, int, WCHAR *, int); - DLLIMPORT extern __stdcall void OutputDebugStringW(const WCHAR *); - DLLIMPORT extern __stdcall int IsDebuggerPresent(); + __declspec(dllimport) extern __stdcall void OutputDebugStringW(const WCHAR *); + __declspec(dllimport) extern __stdcall int IsDebuggerPresent(); - DLLIMPORT extern int cygwin_conv_path(int, const void *, void *, int); - DLLIMPORT extern int cygwin_conv_path_list(int, const void *, void *, int); + __declspec(dllimport) extern int cygwin_conv_path(int, const void *, void *, int); + __declspec(dllimport) extern int cygwin_conv_path_list(int, const void *, void *, int); # define USE_PUTENV 1 # define USE_PUTENV_FOR_UNSET 1 /* On Cygwin, the environment is imported from the Cygwin DLL. */ # define environ __cygwin_environ # define timezone _timezone - DLLIMPORT extern char **__cygwin_environ; - MODULE_SCOPE int TclOSstat(const char *name, Tcl_StatBuf *statBuf); - MODULE_SCOPE int TclOSlstat(const char *name, Tcl_StatBuf *statBuf); -#elif defined(HAVE_STRUCT_STAT64) + extern char **__cygwin_environ; + extern int TclOSstat(const char *name, void *statBuf); + extern int TclOSlstat(const char *name, void *statBuf); +#elif defined(HAVE_STRUCT_STAT64) && !defined(__APPLE__) # define TclOSstat stat64 # define TclOSlstat lstat64 #else @@ -126,9 +122,7 @@ typedef off_t Tcl_SeekOffset; #ifdef HAVE_SYS_SELECT_H # include <sys/select.h> #endif -#ifdef HAVE_SYS_STAT_H -# include <sys/stat.h> -#endif +#include <sys/stat.h> #if TIME_WITH_SYS_TIME # include <sys/time.h> # include <time.h> @@ -159,7 +153,7 @@ typedef off_t Tcl_SeekOffset; # include "../compat/unistd.h" #endif -MODULE_SCOPE int TclUnixSetBlockingMode(int fd, int mode); +extern int TclUnixSetBlockingMode(int fd, int mode); #include <utime.h> @@ -319,7 +313,7 @@ MODULE_SCOPE int TclUnixSetBlockingMode(int fd, int mode); #endif #ifdef GETTOD_NOT_DECLARED -MODULE_SCOPE int gettimeofday(struct timeval *tp, +extern int gettimeofday(struct timeval *tp, struct timezone *tzp); #endif @@ -737,15 +731,15 @@ typedef int socklen_t; #include <pwd.h> #include <grp.h> -MODULE_SCOPE struct passwd * TclpGetPwNam(const char *name); -MODULE_SCOPE struct group * TclpGetGrNam(const char *name); -MODULE_SCOPE struct passwd * TclpGetPwUid(uid_t uid); -MODULE_SCOPE struct group * TclpGetGrGid(gid_t gid); -MODULE_SCOPE struct hostent * TclpGetHostByName(const char *name); -MODULE_SCOPE struct hostent * TclpGetHostByAddr(const char *addr, +extern struct passwd * TclpGetPwNam(const char *name); +extern struct group * TclpGetGrNam(const char *name); +extern struct passwd * TclpGetPwUid(uid_t uid); +extern struct group * TclpGetGrGid(gid_t gid); +extern struct hostent * TclpGetHostByName(const char *name); +extern struct hostent * TclpGetHostByAddr(const char *addr, int length, int type); -MODULE_SCOPE Tcl_Channel TclpMakeTcpClientChannelMode( - ClientData tcpSocket, int mode); +extern void *TclpMakeTcpClientChannelMode( + void *tcpSocket, int mode); #endif /* _TCLUNIXPORT */ diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c index 31daa62..528f009 100644 --- a/unix/tclUnixSock.c +++ b/unix/tclUnixSock.c @@ -1202,7 +1202,7 @@ Tcl_Channel Tcl_MakeTcpClientChannel( ClientData sock) /* The socket to wrap up into a channel. */ { - return TclpMakeTcpClientChannelMode(sock, (TCL_READABLE | TCL_WRITABLE)); + return (Tcl_Channel) TclpMakeTcpClientChannelMode(sock, (TCL_READABLE | TCL_WRITABLE)); } /* @@ -1222,9 +1222,9 @@ Tcl_MakeTcpClientChannel( *---------------------------------------------------------------------- */ -Tcl_Channel +void * TclpMakeTcpClientChannelMode( - ClientData sock, /* The socket to wrap up into a channel. */ + void *sock, /* The socket to wrap up into a channel. */ int mode) /* ORed combination of TCL_READABLE and * TCL_WRITABLE to indicate file mode. */ { diff --git a/unix/tclUnixTest.c b/unix/tclUnixTest.c index c0c05f0..3bed9b2 100644 --- a/unix/tclUnixTest.c +++ b/unix/tclUnixTest.c @@ -200,7 +200,7 @@ TestfilehandlerCmd( return TCL_ERROR; } sprintf(buf, "%d %d", pipePtr->readCount, pipePtr->writeCount); - Tcl_SetResult(interp, buf, TCL_VOLATILE); + Tcl_AppendResult(interp, buf, NULL); } else if (strcmp(argv[1], "create") == 0) { if (argc != 5) { Tcl_AppendResult(interp, "wrong # arguments: should be \"", @@ -217,8 +217,8 @@ TestfilehandlerCmd( fcntl(GetFd(pipePtr->readFile), F_SETFL, O_NONBLOCK); fcntl(GetFd(pipePtr->writeFile), F_SETFL, O_NONBLOCK); #else - Tcl_SetResult(interp, "can't make pipes non-blocking", - TCL_STATIC); + Tcl_AppendResult(interp, "can't make pipes non-blocking", + NULL); return TCL_ERROR; #endif } @@ -281,7 +281,7 @@ TestfilehandlerCmd( memset(buffer, 'b', 10); TclFormatInt(buf, write(GetFd(pipePtr->writeFile), buffer, 10)); - Tcl_SetResult(interp, buf, TCL_VOLATILE); + Tcl_AppendResult(interp, buf, NULL); } else if (strcmp(argv[1], "oneevent") == 0) { Tcl_DoOneEvent(TCL_FILE_EVENTS|TCL_DONT_WAIT); } else if (strcmp(argv[1], "wait") == 0) { @@ -390,7 +390,7 @@ TestfilewaitCmd( if (Tcl_GetChannelHandle(channel, (mask & TCL_READABLE) ? TCL_READABLE : TCL_WRITABLE, (ClientData*) &data) != TCL_OK) { - Tcl_SetResult(interp, "couldn't get channel file", TCL_STATIC); + Tcl_AppendResult(interp, "couldn't get channel file", NULL); return TCL_ERROR; } fd = PTR2INT(data); diff --git a/unix/tclUnixTime.c b/unix/tclUnixTime.c index 6e8c5f4..5fbbe54 100644 --- a/unix/tclUnixTime.c +++ b/unix/tclUnixTime.c @@ -383,7 +383,7 @@ SetTZIfNecessary(void) if (lastTZ == NULL) { Tcl_CreateExitHandler(CleanupMemory, NULL); } else { - Tcl_Free(lastTZ); + ckfree(lastTZ); } lastTZ = ckalloc(strlen(newTZ) + 1); strcpy(lastTZ, newTZ); diff --git a/unix/tclooConfig.sh b/unix/tclooConfig.sh index 5cb4d99..721825b 100644 --- a/unix/tclooConfig.sh +++ b/unix/tclooConfig.sh @@ -16,4 +16,4 @@ TCLOO_STUB_LIB_SPEC="" TCLOO_INCLUDE_SPEC="" TCLOO_PRIVATE_INCLUDE_SPEC="" TCLOO_CFLAGS="" -TCLOO_VERSION=0.7 +TCLOO_VERSION=1.0 diff --git a/win/Makefile.in b/win/Makefile.in index 8cfb68c..8582600 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -82,6 +82,11 @@ CFLAGS_OPTIMIZE = @CFLAGS_OPTIMIZE@ #CFLAGS = $(CFLAGS_DEBUG) $(CFLAGS_OPTIMIZE) CFLAGS = @CFLAGS@ @CFLAGS_DEFAULT@ -DUNICODE -D_UNICODE +# To compile without backward compatibility and deprecated code uncomment the +# following +NO_DEPRECATED_FLAGS = +#NO_DEPRECATED_FLAGS = -DTCL_NO_DEPRECATED + # To enable compilation debugging reverse the comment characters on one of the # following lines. COMPILE_DEBUG_FLAGS = @@ -187,7 +192,7 @@ COPY = cp CC_SWITCHES = ${CFLAGS} ${CFLAGS_WARNING} ${TCL_SHLIB_CFLAGS} -I"${ZLIB_DIR}" \ -I"${GENERIC_DIR_NATIVE}" -DTCL_TOMMATH -DMP_PREC=4 -I"${TOMMATH_DIR_NATIVE}" \ -I"${WIN_DIR_NATIVE}" ${AC_FLAGS} \ -${COMPILE_DEBUG_FLAGS} +${COMPILE_DEBUG_FLAGS} ${NO_DEPRECATED_FLAGS} CC_OBJNAME = @CC_OBJNAME@ CC_EXENAME = @CC_EXENAME@ @@ -634,8 +639,8 @@ install-libraries: libraries install-tzdata install-msgs do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/http1.0"; \ done; - @echo "Installing package http 2.8.5 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.6/http-2.8.5.tm; + @echo "Installing package http 2.8.6 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.6/http-2.8.6.tm; @echo "Installing library opt0.4 directory"; @for j in $(ROOT_DIR)/library/opt/*.tcl; \ do \ @@ -751,7 +756,7 @@ packages: if [ ! -f $(PKG_DIR)/$$pkg/Makefile ]; then \ ( cd $(PKG_DIR)/$$pkg; \ echo "Configuring package '$$i' wd = `pwd -P`"; \ - $$i/configure --with-tcl=$(PWD) --with-tclinclude=$(GENERIC_DIR) $(PKG_CFG_ARGS) --enable-shared --enable-threads; ) \ + $$i/configure --with-tcl=$$builddir --with-tclinclude=$(GENERIC_DIR) $(PKG_CFG_ARGS) --enable-shared --enable-threads; ) \ fi ; \ echo "Building package '$$pkg'"; \ ( cd $(PKG_DIR)/$$pkg; $(MAKE); ) \ @@ -3,50 +3,124 @@ # # Locate the tclConfig.sh file and perform a sanity check on # the Tcl compile flags -# Currently a no-op for Windows # # Arguments: -# PATCH_LEVEL The patch level for Tcl if any. +# none # # Results: # # Adds the following arguments to configure: # --with-tcl=... # -# Sets the following vars: -# TCL_BIN_DIR Full path to the tclConfig.sh file +# Defines the following vars: +# TCL_BIN_DIR Full path to the directory containing +# the tclConfig.sh file #------------------------------------------------------------------------ AC_DEFUN([SC_PATH_TCLCONFIG], [ - AC_MSG_CHECKING([the location of tclConfig.sh]) + # + # Ok, lets find the tcl configuration + # First, look for one uninstalled. + # the alternative search directory is invoked by --with-tcl + # - if test -d ../../tcl8.6$1/win; then - TCL_BIN_DIR_DEFAULT=../../tcl8.6$1/win - elif test -d ../../tcl8.6/win; then - TCL_BIN_DIR_DEFAULT=../../tcl8.6/win - else - TCL_BIN_DIR_DEFAULT=../../tcl/win - fi + if test x"${no_tcl}" = x ; then + # we reset no_tcl in case something fails here + no_tcl=true + AC_ARG_WITH(tcl, + AC_HELP_STRING([--with-tcl], + [directory containing tcl configuration (tclConfig.sh)]), + with_tclconfig="${withval}") + AC_MSG_CHECKING([for Tcl configuration]) + AC_CACHE_VAL(ac_cv_c_tclconfig,[ + + # First check to see if --with-tcl was specified. + if test x"${with_tclconfig}" != x ; then + case "${with_tclconfig}" in + */tclConfig.sh ) + if test -f "${with_tclconfig}"; then + AC_MSG_WARN([--with-tcl argument should refer to directory containing tclConfig.sh, not to tclConfig.sh itself]) + with_tclconfig="`echo "${with_tclconfig}" | sed 's!/tclConfig\.sh$!!'`" + fi ;; + esac + if test -f "${with_tclconfig}/tclConfig.sh" ; then + ac_cv_c_tclconfig="`(cd "${with_tclconfig}"; pwd)`" + else + AC_MSG_ERROR([${with_tclconfig} directory doesn't contain tclConfig.sh]) + fi + fi - AC_ARG_WITH(tcl, [ --with-tcl=DIR use Tcl 8.6 binaries from DIR], - TCL_BIN_DIR=$withval, TCL_BIN_DIR=`cd $TCL_BIN_DIR_DEFAULT; pwd`) - if test ! -d $TCL_BIN_DIR; then - AC_MSG_ERROR(Tcl directory $TCL_BIN_DIR does not exist) - fi - if test ! -f $TCL_BIN_DIR/tclConfig.sh; then - if test ! -f $TCL_BIN_DIR/../unix/tclConfig.sh; then - AC_MSG_ERROR(There is no tclConfig.sh in $TCL_BIN_DIR: perhaps you did not specify the Tcl *build* directory (not the toplevel Tcl directory) or you forgot to configure Tcl?) + # then check for a private Tcl installation + if test x"${ac_cv_c_tclconfig}" = x ; then + for i in \ + ../tcl \ + `ls -dr ../tcl[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \ + `ls -dr ../tcl[[8-9]].[[0-9]] 2>/dev/null` \ + `ls -dr ../tcl[[8-9]].[[0-9]]* 2>/dev/null` \ + ../../tcl \ + `ls -dr ../../tcl[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \ + `ls -dr ../../tcl[[8-9]].[[0-9]] 2>/dev/null` \ + `ls -dr ../../tcl[[8-9]].[[0-9]]* 2>/dev/null` \ + ../../../tcl \ + `ls -dr ../../../tcl[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \ + `ls -dr ../../../tcl[[8-9]].[[0-9]] 2>/dev/null` \ + `ls -dr ../../../tcl[[8-9]].[[0-9]]* 2>/dev/null` ; do + if test -f "$i/win/tclConfig.sh" ; then + ac_cv_c_tclconfig="`(cd $i/win; pwd)`" + break + fi + done + fi + + # check in a few common install locations + if test x"${ac_cv_c_tclconfig}" = x ; then + for i in `ls -d ${libdir} 2>/dev/null` \ + `ls -d ${exec_prefix}/lib 2>/dev/null` \ + `ls -d ${prefix}/lib 2>/dev/null` \ + `ls -d /cygdrive/c/Tcl/lib 2>/dev/null` \ + `ls -d /cygdrive/c/Progra~1/Tcl/lib 2>/dev/null` \ + `ls -d /c/Tcl/lib 2>/dev/null` \ + `ls -d /c/Progra~1/Tcl/lib 2>/dev/null` \ + `ls -d C:/Tcl/lib 2>/dev/null` \ + `ls -d C:/Progra~1/Tcl/lib 2>/dev/null` \ + ; do + if test -f "$i/tclConfig.sh" ; then + ac_cv_c_tclconfig="`(cd $i; pwd)`" + break + fi + done + fi + + # check in a few other private locations + if test x"${ac_cv_c_tclconfig}" = x ; then + for i in \ + ${srcdir}/../tcl \ + `ls -dr ${srcdir}/../tcl[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \ + `ls -dr ${srcdir}/../tcl[[8-9]].[[0-9]] 2>/dev/null` \ + `ls -dr ${srcdir}/../tcl[[8-9]].[[0-9]]* 2>/dev/null` ; do + if test -f "$i/win/tclConfig.sh" ; then + ac_cv_c_tclconfig="`(cd $i/win; pwd)`" + break + fi + done + fi + ]) + + if test x"${ac_cv_c_tclconfig}" = x ; then + TCL_BIN_DIR="# no Tcl configs found" + AC_MSG_ERROR([Can't find Tcl configuration definitions. Use --with-tcl to specify a directory containing tclConfig.sh]) + else + no_tcl= + TCL_BIN_DIR="${ac_cv_c_tclconfig}" + AC_MSG_RESULT([found ${TCL_BIN_DIR}/tclConfig.sh]) fi - TCL_BIN_DIR=`cd ${TCL_BIN_DIR}/../unix; pwd` fi - AC_MSG_RESULT($TCL_BIN_DIR/tclConfig.sh) ]) #------------------------------------------------------------------------ # SC_PATH_TKCONFIG -- # # Locate the tkConfig.sh file -# Currently a no-op for Windows # # Arguments: # none @@ -56,31 +130,109 @@ AC_DEFUN([SC_PATH_TCLCONFIG], [ # Adds the following arguments to configure: # --with-tk=... # -# Sets the following vars: -# TK_BIN_DIR Full path to the tkConfig.sh file +# Defines the following vars: +# TK_BIN_DIR Full path to the directory containing +# the tkConfig.sh file #------------------------------------------------------------------------ AC_DEFUN([SC_PATH_TKCONFIG], [ - AC_MSG_CHECKING([the location of tkConfig.sh]) + # + # Ok, lets find the tk configuration + # First, look for one uninstalled. + # the alternative search directory is invoked by --with-tk + # - if test -d ../../tk8.6$1/win; then - TK_BIN_DIR_DEFAULT=../../tk8.6$1/win - elif test -d ../../tk8.6/win; then - TK_BIN_DIR_DEFAULT=../../tk8.6/win - else - TK_BIN_DIR_DEFAULT=../../tk/win - fi + if test x"${no_tk}" = x ; then + # we reset no_tk in case something fails here + no_tk=true + AC_ARG_WITH(tk, + AC_HELP_STRING([--with-tk], + [directory containing tk configuration (tkConfig.sh)]), + with_tkconfig="${withval}") + AC_MSG_CHECKING([for Tk configuration]) + AC_CACHE_VAL(ac_cv_c_tkconfig,[ + + # First check to see if --with-tkconfig was specified. + if test x"${with_tkconfig}" != x ; then + case "${with_tkconfig}" in + */tkConfig.sh ) + if test -f "${with_tkconfig}"; then + AC_MSG_WARN([--with-tk argument should refer to directory containing tkConfig.sh, not to tkConfig.sh itself]) + with_tkconfig="`echo "${with_tkconfig}" | sed 's!/tkConfig\.sh$!!'`" + fi ;; + esac + if test -f "${with_tkconfig}/tkConfig.sh" ; then + ac_cv_c_tkconfig="`(cd "${with_tkconfig}"; pwd)`" + else + AC_MSG_ERROR([${with_tkconfig} directory doesn't contain tkConfig.sh]) + fi + fi - AC_ARG_WITH(tk, [ --with-tk=DIR use Tk 8.6 binaries from DIR], - TK_BIN_DIR=$withval, TK_BIN_DIR=`cd $TK_BIN_DIR_DEFAULT; pwd`) - if test ! -d $TK_BIN_DIR; then - AC_MSG_ERROR(Tk directory $TK_BIN_DIR does not exist) - fi - if test ! -f $TK_BIN_DIR/tkConfig.sh; then - AC_MSG_ERROR(There is no tkConfig.sh in $TK_BIN_DIR: perhaps you did not specify the Tk *build* directory (not the toplevel Tk directory) or you forgot to configure Tk?) - fi + # then check for a private Tk library + if test x"${ac_cv_c_tkconfig}" = x ; then + for i in \ + ../tk \ + `ls -dr ../tk[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \ + `ls -dr ../tk[[8-9]].[[0-9]] 2>/dev/null` \ + `ls -dr ../tk[[8-9]].[[0-9]]* 2>/dev/null` \ + ../../tk \ + `ls -dr ../../tk[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \ + `ls -dr ../../tk[[8-9]].[[0-9]] 2>/dev/null` \ + `ls -dr ../../tk[[8-9]].[[0-9]]* 2>/dev/null` \ + ../../../tk \ + `ls -dr ../../../tk[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \ + `ls -dr ../../../tk[[8-9]].[[0-9]] 2>/dev/null` \ + `ls -dr ../../../tk[[8-9]].[[0-9]]* 2>/dev/null` ; do + if test -f "$i/win/tkConfig.sh" ; then + ac_cv_c_tkconfig="`(cd $i/win; pwd)`" + break + fi + done + fi - AC_MSG_RESULT([$TK_BIN_DIR/tkConfig.sh]) + # check in a few common install locations + if test x"${ac_cv_c_tkconfig}" = x ; then + for i in `ls -d ${libdir} 2>/dev/null` \ + `ls -d ${exec_prefix}/lib 2>/dev/null` \ + `ls -d ${prefix}/lib 2>/dev/null` \ + `ls -d /cygdrive/c/Tcl/lib 2>/dev/null` \ + `ls -d /cygdrive/c/Progra~1/Tcl/lib 2>/dev/null` \ + `ls -d /c/Tcl/lib 2>/dev/null` \ + `ls -d /c/Progra~1/Tcl/lib 2>/dev/null` \ + `ls -d C:/Tcl/lib 2>/dev/null` \ + `ls -d C:/Progra~1/Tcl/lib 2>/dev/null` \ + ; do + if test -f "$i/tkConfig.sh" ; then + ac_cv_c_tkconfig="`(cd $i; pwd)`" + break + fi + done + fi + + # check in a few other private locations + if test x"${ac_cv_c_tkconfig}" = x ; then + for i in \ + ${srcdir}/../tk \ + `ls -dr ${srcdir}/../tk[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \ + `ls -dr ${srcdir}/../tk[[8-9]].[[0-9]] 2>/dev/null` \ + `ls -dr ${srcdir}/../tk[[8-9]].[[0-9]]* 2>/dev/null` ; do + if test -f "$i/win/tkConfig.sh" ; then + ac_cv_c_tkconfig="`(cd $i/win; pwd)`" + break + fi + done + fi + ]) + + if test x"${ac_cv_c_tkconfig}" = x ; then + TK_BIN_DIR="# no Tk configs found" + AC_MSG_ERROR([Can't find Tk configuration definitions. Use --with-tk to specify a directory containing tkConfig.sh]) + else + no_tk= + TK_BIN_DIR="${ac_cv_c_tkconfig}" + AC_MSG_RESULT([found ${TK_BIN_DIR}/tkConfig.sh]) + fi + fi ]) #------------------------------------------------------------------------ diff --git a/win/tclWinFile.c b/win/tclWinFile.c index a1189f5..19e6abd 100644 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -12,10 +12,10 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ +#include <sys/stat.h> #include "tclWinInt.h" #include "tclFileSystem.h" #include <winioctl.h> -#include <sys/stat.h> #include <shlobj.h> #include <lm.h> /* For TclpGetUserHome(). */ @@ -160,7 +160,7 @@ static unsigned short NativeStatMode(DWORD attr, int checkLinks, int isExec); static int NativeIsExec(const TCHAR *path); static int NativeReadReparse(const TCHAR *LinkDirectory, - REPARSE_DATA_BUFFER *buffer); + REPARSE_DATA_BUFFER *buffer, DWORD desiredAccess); static int NativeWriteReparse(const TCHAR *LinkDirectory, REPARSE_DATA_BUFFER *buffer); static int NativeMatchType(int isDrive, DWORD attr, @@ -444,7 +444,7 @@ TclWinSymLinkCopyDirectory( DUMMY_REPARSE_BUFFER dummy; REPARSE_DATA_BUFFER *reparseBuffer = (REPARSE_DATA_BUFFER *) &dummy; - if (NativeReadReparse(linkOrigPath, reparseBuffer)) { + if (NativeReadReparse(linkOrigPath, reparseBuffer, GENERIC_READ)) { return -1; } return NativeWriteReparse(linkCopyPath, reparseBuffer); @@ -542,7 +542,7 @@ WinReadLinkDirectory( if (!(attr & FILE_ATTRIBUTE_REPARSE_POINT)) { goto invalidError; } - if (NativeReadReparse(linkDirPath, reparseBuffer)) { + if (NativeReadReparse(linkDirPath, reparseBuffer, 0)) { return NULL; } @@ -663,12 +663,13 @@ WinReadLinkDirectory( static int NativeReadReparse( const TCHAR *linkDirPath, /* The junction to read */ - REPARSE_DATA_BUFFER *buffer)/* Pointer to buffer. Cannot be NULL */ + REPARSE_DATA_BUFFER *buffer,/* Pointer to buffer. Cannot be NULL */ + DWORD desiredAccess) { HANDLE hFile; DWORD returnedLength; - hFile = CreateFile(linkDirPath, GENERIC_READ, 0, NULL, OPEN_EXISTING, + hFile = CreateFile(linkDirPath, desiredAccess, 0, NULL, OPEN_EXISTING, FILE_FLAG_OPEN_REPARSE_POINT | FILE_FLAG_BACKUP_SEMANTICS, NULL); if (hFile == INVALID_HANDLE_VALUE) { diff --git a/win/tclWinTest.c b/win/tclWinTest.c index 136c4db..b83c0ba 100644 --- a/win/tclWinTest.c +++ b/win/tclWinTest.c @@ -211,7 +211,7 @@ TestvolumetypeCmd( TclWinConvertError(GetLastError()); return TCL_ERROR; } - Tcl_SetResult(interp, volType, TCL_VOLATILE); + Tcl_AppendResult(interp, volType, NULL); return TCL_OK; #undef VOL_BUF_SIZE } diff --git a/win/tclooConfig.sh b/win/tclooConfig.sh index 5cb4d99..721825b 100644 --- a/win/tclooConfig.sh +++ b/win/tclooConfig.sh @@ -16,4 +16,4 @@ TCLOO_STUB_LIB_SPEC="" TCLOO_INCLUDE_SPEC="" TCLOO_PRIVATE_INCLUDE_SPEC="" TCLOO_CFLAGS="" -TCLOO_VERSION=0.7 +TCLOO_VERSION=1.0 |