diff options
199 files changed, 5267 insertions, 5343 deletions
diff --git a/.fossil-settings/binary-glob b/.fossil-settings/binary-glob new file mode 100644 index 0000000..ca85874 --- /dev/null +++ b/.fossil-settings/binary-glob @@ -0,0 +1,3 @@ +*.bmp +*.gif +*.png diff --git a/.fossil-settings/crnl-glob b/.fossil-settings/crnl-glob new file mode 100644 index 0000000..e69de29 --- /dev/null +++ b/.fossil-settings/crnl-glob diff --git a/.fossil-settings/ignore-glob b/.fossil-settings/ignore-glob new file mode 100644 index 0000000..a101893 --- /dev/null +++ b/.fossil-settings/ignore-glob @@ -0,0 +1,15 @@ +*.a +*.dll +*.exe +*.o +*.obj +*.so +*/Makefile +*/config.cache +*/config.log +*/config.status +*/tclConfig.sh +*/tclsh* +*/tcltest* +unix/dltest.marker +win/tcl.hpj diff --git a/.project b/.project new file mode 100644 index 0000000..8a6f036 --- /dev/null +++ b/.project @@ -0,0 +1,11 @@ +<?xml version="1.0" encoding="UTF-8"?> +<projectDescription> + <name>tcl9.0</name> + <comment></comment> + <projects> + </projects> + <buildSpec> + </buildSpec> + <natures> + </natures> +</projectDescription> diff --git a/.settings/org.eclipse.core.resources.prefs b/.settings/org.eclipse.core.resources.prefs new file mode 100644 index 0000000..99f26c0 --- /dev/null +++ b/.settings/org.eclipse.core.resources.prefs @@ -0,0 +1,2 @@ +eclipse.preferences.version=1 +encoding/<project>=UTF-8 diff --git a/.settings/org.eclipse.core.runtime.prefs b/.settings/org.eclipse.core.runtime.prefs new file mode 100644 index 0000000..5a0ad22 --- /dev/null +++ b/.settings/org.eclipse.core.runtime.prefs @@ -0,0 +1,2 @@ +eclipse.preferences.version=1 +line.separator=\n @@ -1,14 +1,321 @@ -2012-11-13 Miguel Sofer <msofer@users.sf.net> +2013-02-28 Don Porter <dgp@users.sourceforge.net> - * generic/tclCmdAH.c (CatchObjCmdCallback): do not decrRefCount - the newValuePtr sent to Tcl_ObjSetVar2: TOSV2 is 'fire and - forget', it decrs on its own. Fix for [Bug 3595576], found by - andrewsh. + * generic/tclLiteral.c: Revise TclReleaseLiteral() to tolerate a + NULL interp argument. + + * generic/tclCompile.c: Update callers and revise mistaken comments. + * generic/tclProc.c: + +2013-02-27 Jan Nijtmans <nijtmans@users.sf.net> + + * generic/regcomp.c: [Bug 3606139]: missing error check allows + * tests/regexp.test: regexp to crash Tcl. Thanks to Tom Lane for + providing the test-case and the patch. + +2013-02-26 Donal K. Fellows <dkf@users.sf.net> + + * tests/chanio.test (chan-io-28.7): [Bug 3605120]: Stop test from + hanging when run standalone. + +2013-02-26 Jan Nijtmans <nijtmans@users.sf.net> + + * generic/tclObj.c: Don't panic if Tcl_ConvertToType is called for a + type that doesn't have a setFromAnyProc, create a proper error message. + +2013-02-25 Donal K. Fellows <dkf@users.sf.net> + + * tests/binary.test (binary-41.*): [Bug 3605721]: Test independence + fixes. Thanks to Rolf Ade for pointing out the problem. + +2013-02-25 Don Porter <dgp@users.sourceforge.net> + + * tests/assocd.test: [Bugs 3605719,3605720]: Test independence. + * tests/basic.test: Thanks Rolf Ade for patches. + +2013-02-23 Jan Nijtmans <nijtmans@users.sf.net> + + * compat/fake-rfc2553.c: [Bug 3599194]: compat/fake-rfc2553.c is + broken. + +2013-02-22 Don Porter <dgp@users.sourceforge.net> + + * generic/tclAssembly.c: Shift more burden of smart cleanup + * generic/tclCompile.c: onto the TclFreeCompileEnv() routine. + Stop crashes when the hookProc raises an error. + +2013-02-20 Don Porter <dgp@users.sourceforge.net> + + * generic/tclNamesp.c: [Bug 3605447]: Make sure the -clear option + * tests/namespace.test: to [namespace export] always clears, whether + or not new export patterns are specified. + +2013-02-20 Jan Nijtmans <nijtmans@users.sf.net> + + * win/tclWinDde.c: [Bug 3605401]: Compiler error with latest mingw-w64 + headers. + +2013-02-19 Jan Nijtmans <nijtmans@users.sf.net> + + * generic/tclTrace.c: [Bug 2438181]: Incorrect error reporting in + * tests/trace.test: traces. Test-case and fix provided by Poor + Yorick. + +2013-02-15 Don Porter <dgp@users.sourceforge.net> + + * generic/regc_nfa.c: [Bug 3604074]: Fix regexp optimization to + * tests/regexp.test: stop hanging on the expression + ((((((((a)*)*)*)*)*)*)*)* . Thanks to Bjørn Grathwohl for discovery. + +2013-02-14 Harald Oehlmann <oehhar@users.sf.net> + + * library/msgcat/msgcat.tcl: [Bug 3604576]: Catch missing registry + entry "HCU\Control Panel\International". + Bumped msgcat version to 1.5.1 + +2013-02-11 Donal K. Fellows <dkf@users.sf.net> + + * generic/tclZlib.c (ZlibTransformOutput): [Bug 3603553]: Ensure that + data gets written to the underlying stream by compressing transforms + when the amount of data to be written is one buffer's-worth; problem + was particularly likely to occur when compressing large quantities of + not-very-compressible data. Many thanks to Piera Poggio (vampiera) for + reporting. + +2013-02-09 Donal K. Fellows <dkf@users.sf.net> + + * generic/tclOOBasic.c (TclOO_Object_VarName): [Bug 3603695]: Change + the way that the 'varname' method is implemented so that there are no + longer problems with interactions due to the resolver. Thanks to + Taylor Venable <tcvena@gmail.com> for identifying the problem. + +2013-02-08 Donal K. Fellows <dkf@users.sf.net> + + * generic/regc_nfa.c (duptraverse): [Bug 3603557]: Increase the + maximum depth of recursion used when duplicating an automaton in + response to encountering a "wild" RE that hit the previous limit. + Allow the limit (DUPTRAVERSE_MAX_DEPTH) to be set by defining its + value in the Makefile. Problem reported by Jonathan Mills. + +2013-02-05 Don Porter <dgp@users.sourceforge.net> + + * win/tclWinFile.c: [Bug 3603434]: Make sure TclpObjNormalizePath() + properly declares "a:/" to be normalized, even when no "A:" drive is + present on the system. + +2013-02-05 Donal K. Fellows <dkf@users.sf.net> + + * generic/tclLoadNone.c (TclpLoadMemory): [Bug 3433012]: Added dummy + version of this function to use in the event that a platform thinks it + can load from memory but cannot actually do so due to it being + disabled at configuration time. + +2013-02-04 Donal K. Fellows <dkf@users.sf.net> + + * generic/tclCompCmds.c (TclCompileArraySetCmd): [Bug 3603163]: Stop + crash in weird case where [eval] is used to make [array set] get + confused about whether there is a local variable table or not. Thanks + to Poor Yorick for identifying a reproducible crashing case. + +2013-01-30 Andreas Kupries <andreask@activestate.com> + + * library/platform/platform.tcl (::platform::LibcVersion): See + * library/platform/pkgIndex.tcl: [Bug 3599098]: Fixed the RE + * unix/Makefile.in: extracting the version to avoid issues with + * win/Makefile.in: recent changes to the glibc banner. Now targeting a + less variable part of the string. Bumped package to version 1.0.11. + +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-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-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. + * tests/exec.test: + * tests/reg.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: [Bug 3598150]: Stop leaking allocated space when + objifying a zero-length DString. 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. + * 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> @@ -4000,6 +4307,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] @@ -8158,4 +8158,8 @@ Dropped support for OS X versions less than 10.4 (Tiger) (fellows) 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/fake-rfc2553.c b/compat/fake-rfc2553.c index 666144f..3b91041 100644 --- a/compat/fake-rfc2553.c +++ b/compat/fake-rfc2553.c @@ -84,7 +84,7 @@ int fake_getnameinfo(const struct sockaddr *sa, size_t salen, char *host, if (host != NULL) { if (flags & NI_NUMERICHOST) { - int len; + size_t len; Tcl_MutexLock(&netdbMutex); len = strlcpy(host, inet_ntoa(sin->sin_addr), hostlen); Tcl_MutexUnlock(&netdbMutex); @@ -135,7 +135,7 @@ fake_gai_strerror(int err) #ifndef HAVE_FREEADDRINFO void -freeaddrinfo(struct addrinfo *ai) +fake_freeaddrinfo(struct addrinfo *ai) { struct addrinfo *next; @@ -199,7 +199,7 @@ fake_getaddrinfo(const char *hostname, const char *servname, port = strtol(servname, &cp, 10); if (port > 0 && port <= 65535 && *cp == '\0') - port = htons(port); + port = htons((unsigned short)port); else if ((sp = getservbyname(servname, NULL)) != NULL) port = sp->s_port; else diff --git a/compat/float.h b/compat/float.h deleted file mode 100644 index 411edbf..0000000 --- a/compat/float.h +++ /dev/null @@ -1,14 +0,0 @@ -/* - * float.h -- - * - * This is a dummy header file to #include in Tcl when there - * is no float.h in /usr/include. Right now this file is empty: - * Tcl contains #ifdefs to deal with the lack of definitions; - * all it needs is for the #include statement to work. - * - * Copyright (c) 1993 The Regents of the University of California. - * Copyright (c) 1994 Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - */ 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..21be04f 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 9.0 ABI on Unix platforms, +the library name is \fIlibtclstub9.0.a\fR; on Windows platforms, the +library name is \fItclstub90.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 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/msgcat.n b/doc/msgcat.n index 57fbb78..47b6bf7 100644 --- a/doc/msgcat.n +++ b/doc/msgcat.n @@ -13,7 +13,7 @@ msgcat \- Tcl message catalog .SH SYNOPSIS \fBpackage require Tcl 8.5\fR .sp -\fBpackage require msgcat 1.5.0\fR +\fBpackage require msgcat 1.5\fR .sp \fB::msgcat::mc \fIsrc-string\fR ?\fIarg arg ...\fR? .sp 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 . @@ -87,7 +87,7 @@ Handle different reasons for a file to not be openable for reading: .PP .CS \fBtry\fR { - set f [open /some/file/name] + set f [open /some/file/name w] } \fBtrap\fR {POSIX EISDIR} {} { puts "failed to open /some/file/name: it's a directory" } \fBtrap\fR {POSIX ENOENT} {} { diff --git a/generic/regc_locale.c b/generic/regc_locale.c index f3db471..7d15f8b 100644 --- a/generic/regc_locale.c +++ b/generic/regc_locale.c @@ -118,7 +118,7 @@ static const struct cname { * Unicode character-class tables. */ -typedef struct crange { +typedef struct { chr start; chr end; } crange; @@ -191,6 +191,10 @@ static const crange alphaRangeTable[] = { {0xaadb, 0xaadd}, {0xaae0, 0xaaea}, {0xaaf2, 0xaaf4}, {0xab01, 0xab06}, {0xab09, 0xab0e}, {0xab11, 0xab16}, {0xab20, 0xab26}, {0xab28, 0xab2e}, {0xabc0, 0xabe2}, {0xac00, 0xd7a3}, {0xd7b0, 0xd7c6}, {0xd7cb, 0xd7fb}, + {0xdc02, 0xdc3e}, {0xdc40, 0xdc7e}, {0xdc80, 0xdcbe}, {0xdcc0, 0xdcfe}, + {0xdd02, 0xdd3e}, {0xdd40, 0xdd7e}, {0xdd80, 0xddbe}, {0xddc0, 0xddfe}, + {0xde02, 0xde3e}, {0xde40, 0xde7e}, {0xde80, 0xdebe}, {0xdec0, 0xdefe}, + {0xdf02, 0xdf3e}, {0xdf40, 0xdf7e}, {0xdf80, 0xdfbe}, {0xdfc0, 0xdffe}, {0xf900, 0xfa6d}, {0xfa70, 0xfad9}, {0xfb00, 0xfb06}, {0xfb13, 0xfb17}, {0xfb1f, 0xfb28}, {0xfb2a, 0xfb36}, {0xfb38, 0xfb3c}, {0xfb46, 0xfbb1}, {0xfbd3, 0xfd3d}, {0xfd50, 0xfd8f}, {0xfd92, 0xfdc7}, {0xfdf0, 0xfdfb}, @@ -242,7 +246,8 @@ static const chr alphaCharTable[] = { 0x207f, 0x2102, 0x2107, 0x2115, 0x2124, 0x2126, 0x2128, 0x214e, 0x2183, 0x2184, 0x2cf2, 0x2cf3, 0x2d27, 0x2d2d, 0x2d6f, 0x2e2f, 0x3005, 0x3006, 0x303b, 0x303c, 0xa62a, 0xa62b, 0xa8fb, 0xa9cf, 0xaa7a, 0xaab1, 0xaab5, - 0xaab6, 0xaac0, 0xaac2, 0xfb1d, 0xfb3e, 0xfb40, 0xfb41, 0xfb43, 0xfb44 + 0xaab6, 0xaac0, 0xaac2, 0xdc00, 0xdd00, 0xde00, 0xdf00, 0xfb1d, 0xfb3e, + 0xfb40, 0xfb41, 0xfb43, 0xfb44 #if TCL_UTF_MAX > 4 ,0x1003c, 0x1003d, 0x10808, 0x10837, 0x10838, 0x1083c, 0x109be, 0x109bf, 0x10a00, 0x16f50, 0x1b000, 0x1b001, 0x1d49e, 0x1d49f, 0x1d4a2, 0x1d4a5, 0x1d4a6, 0x1d4bb, @@ -260,7 +265,7 @@ static const chr alphaCharTable[] = { static const crange controlRangeTable[] = { {0x7f, 0x9f}, {0x600, 0x604}, {0x200b, 0x200f}, {0x202a, 0x202e}, - {0x2060, 0x2064}, {0x206a, 0x206f}, {0xe000, 0xf8ff}, {0xfff9, 0xfffb} + {0x2060, 0x2064}, {0x2066, 0x206f}, {0xe000, 0xf8ff}, {0xfff9, 0xfffb} #if TCL_UTF_MAX > 4 ,{0x1d173, 0x1d17a}, {0xe0020, 0xe007f}, {0xf0000, 0xffffd}, {0x100000, 0x10fffd} #endif @@ -269,7 +274,7 @@ static const crange controlRangeTable[] = { #define NUM_CONTROL_RANGE (sizeof(controlRangeTable)/sizeof(crange)) static const chr controlCharTable[] = { - 0xad, 0x6dd, 0x70f, 0xfeff + 0xad, 0x61c, 0x6dd, 0x70f, 0x180e, 0xfeff #if TCL_UTF_MAX > 4 ,0x110bd, 0xe0001 #endif @@ -636,7 +641,11 @@ static const crange graphRangeTable[] = { {0xaa40, 0xaa4d}, {0xaa50, 0xaa59}, {0xaa5c, 0xaa7b}, {0xaa80, 0xaac2}, {0xaadb, 0xaaf6}, {0xab01, 0xab06}, {0xab09, 0xab0e}, {0xab11, 0xab16}, {0xab20, 0xab26}, {0xab28, 0xab2e}, {0xabc0, 0xabed}, {0xabf0, 0xabf9}, - {0xac00, 0xd7a3}, {0xd7b0, 0xd7c6}, {0xd7cb, 0xd7fb}, {0xf900, 0xfa6d}, + {0xac00, 0xd7a3}, {0xd7b0, 0xd7c6}, {0xd7cb, 0xd7fb}, {0xdc00, 0xdc3e}, + {0xdc42, 0xdc7e}, {0xdc80, 0xdcbe}, {0xdcc0, 0xdcfe}, {0xdd00, 0xdd3e}, + {0xdd42, 0xdd7e}, {0xdd80, 0xddbe}, {0xddc0, 0xddfe}, {0xde00, 0xde3e}, + {0xde42, 0xde7e}, {0xde80, 0xdebe}, {0xdec0, 0xdefe}, {0xdf00, 0xdf3e}, + {0xdf42, 0xdf7e}, {0xdf80, 0xdfbe}, {0xdfc0, 0xdffe}, {0xf900, 0xfa6d}, {0xfa70, 0xfad9}, {0xfb00, 0xfb06}, {0xfb13, 0xfb17}, {0xfb1d, 0xfb36}, {0xfb38, 0xfb3c}, {0xfb46, 0xfbc1}, {0xfbd3, 0xfd3f}, {0xfd50, 0xfd8f}, {0xfd92, 0xfdc7}, {0xfdf0, 0xfdfd}, {0xfe00, 0xfe19}, {0xfe20, 0xfe26}, @@ -695,7 +704,8 @@ static const chr graphCharTable[] = { 0xe84, 0xe87, 0xe88, 0xe8a, 0xe8d, 0xea5, 0xea7, 0xeaa, 0xeab, 0xec6, 0x10c7, 0x10cd, 0x1258, 0x12c0, 0x1772, 0x1773, 0x1940, 0x1f59, 0x1f5b, 0x1f5d, 0x2070, 0x2071, 0x2d27, 0x2d2d, 0x2d6f, 0x2d70, 0xa9de, - 0xa9df, 0xfb3e, 0xfb40, 0xfb41, 0xfb43, 0xfb44, 0xfffc, 0xfffd + 0xa9df, 0xdc40, 0xdd40, 0xde40, 0xdf40, 0xfb3e, 0xfb40, 0xfb41, 0xfb43, + 0xfb44, 0xfffc, 0xfffd #if TCL_UTF_MAX > 4 ,0x1003c, 0x1003d, 0x10808, 0x10837, 0x10838, 0x1083c, 0x1093f, 0x109be, 0x109bf, 0x10a05, 0x10a06, 0x1b000, 0x1b001, 0x1d49e, 0x1d49f, 0x1d4a2, 0x1d4a5, 0x1d4a6, diff --git a/generic/regc_nfa.c b/generic/regc_nfa.c index 4fb3ea6..65147d4 100644 --- a/generic/regc_nfa.c +++ b/generic/regc_nfa.c @@ -759,7 +759,9 @@ duptraverse( * Arbitrary depth limit. Needs tuning, but this value is sufficient to * make all normal tests (not reg-33.14) pass. */ -#define DUPTRAVERSE_MAX_DEPTH 500 +#ifndef DUPTRAVERSE_MAX_DEPTH +#define DUPTRAVERSE_MAX_DEPTH 700 +#endif if (depth++ > DUPTRAVERSE_MAX_DEPTH) { NERR(REG_ESPACE); @@ -1246,6 +1248,7 @@ fixempties( { struct state *s; struct state *nexts; + struct state *to; struct arc *a; struct arc *nexta; int progress; @@ -1256,15 +1259,50 @@ fixempties( do { progress = 0; - for (s = nfa->states; s != NULL && !NISERR() - && s->no != FREESTATE; s = nexts) { + for (s = nfa->states; s != NULL && !NISERR(); s = nexts) { nexts = s->next; - for (a = s->outs; a != NULL && !NISERR(); a = nexta) { + for (a = s->outs; a != NULL && !NISERR(); a = a->outchain) { + if (a->type == EMPTY) { + + /* + * Mark a for deletion; copy arcs to preserve graph + * connectivity after it is gone. + */ + + unempty(nfa, a); + } + } + + /* + * Now pass through and delete the marked arcs. Doing all the + * deletion after all the marking prevents arc copying from + * resurrecting deleted arcs which can cause failure to converge. + * [Tcl Bug 3604074] + */ + + for (a = s->outs; a != NULL; a = nexta) { nexta = a->outchain; - if (a->type == EMPTY && unempty(nfa, a)) { + if (a->from == NULL) { progress = 1; + to = a->to; + a->from = s; + freearc(nfa, a); + if (to->nins == 0) { + while ((a = to->outs)) { + freearc(nfa, a); + } + if (nexts == to) { + nexts = to->next; + } + freestate(nfa, to); + } + if (s->nouts == 0) { + while ((a = s->ins)) { + freearc(nfa, a); + } + freestate(nfa, s); + } } - assert(nexta == NULL || s->no != FREESTATE); } } if (progress && f != NULL) { @@ -1286,7 +1324,6 @@ unempty( { struct state *from = a->from; struct state *to = a->to; - int usefrom; /* work on from, as opposed to to? */ assert(a->type == EMPTY); assert(from != nfa->pre && to != nfa->post); @@ -1297,47 +1334,30 @@ unempty( } /* - * Decide which end to work on. + * Mark arc for deletion. */ - usefrom = 1; /* default: attack from */ + a->from = NULL; + if (from->nouts > to->nins) { - usefrom = 0; - } else if (from->nouts == to->nins) { - /* - * Decide on secondary issue: move/copy fewest arcs. - */ - - if (from->nins > to->nouts) { - usefrom = 0; - } + copyouts(nfa, to, from); + return 1; + } + if (from->nouts < to->nins) { + copyins(nfa, from, to); + return 1; } - freearc(nfa, a); - if (usefrom) { - if (from->nouts == 0) { - /* - * Was the state's only outarc. - */ - - moveins(nfa, from, to); - freestate(nfa, from); - } else { - copyins(nfa, from, to); - } - } else { - if (to->nins == 0) { - /* - * Was the state's only inarc. - */ + /* + * from->nouts == to->nins . decide on secondary issue: copy fewest arcs + */ - moveouts(nfa, to, from); - freestate(nfa, to); - } else { - copyouts(nfa, to, from); - } + if (from->nins > to->nouts) { + copyouts(nfa, to, from); + return 1; } + copyins(nfa, from, to); return 1; } diff --git a/generic/regcomp.c b/generic/regcomp.c index 65555aa..b15117b 100644 --- a/generic/regcomp.c +++ b/generic/regcomp.c @@ -738,6 +738,7 @@ parsebranch( /* NB, recursion in parseqatom() may swallow rest of branch */ parseqatom(v, stopper, type, lp, right, t); + NOERRN(); } if (!seencontent) { /* empty branch */ @@ -1234,6 +1235,7 @@ parseqatom( EMPTYARC(atom->end, rp); t->right = subre(v, '=', 0, atom->end, rp); } + NOERR(); assert(SEE('|') || SEE(stopper) || SEE(EOS)); t->flags |= COMBINE(t->flags, t->right->flags); top->flags |= COMBINE(top->flags, t->flags); diff --git a/generic/regguts.h b/generic/regguts.h index e57b8f8..67f9625 100644 --- a/generic/regguts.h +++ b/generic/regguts.h @@ -366,7 +366,7 @@ struct subre { */ struct fns { - VOID FUNCPTR(free, (regex_t *)); + void FUNCPTR(free, (regex_t *)); }; /* diff --git a/generic/tcl.decls b/generic/tcl.decls index e9ab7c0..0a96781 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -104,9 +104,10 @@ declare 20 { declare 21 { int Tcl_DbIsShared(Tcl_Obj *objPtr, const char *file, int line) } -declare 22 { - Tcl_Obj *Tcl_DbNewBooleanObj(int boolValue, const char *file, int line) -} +# Removed in 9.0: +#declare 22 { +# Tcl_Obj *Tcl_DbNewBooleanObj(int boolValue, const char *file, int line) +#} declare 23 { Tcl_Obj *Tcl_DbNewByteArrayObj(const unsigned char *bytes, int length, const char *file, int line) @@ -152,10 +153,11 @@ declare 35 { int Tcl_GetDoubleFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, double *doublePtr) } -declare 36 { - int Tcl_GetIndexFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, - const char *const *tablePtr, const char *msg, int flags, int *indexPtr) -} +# Removed in 9.0 +#declare 36 { +# int Tcl_GetIndexFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, +# const char *const *tablePtr, const char *msg, int flags, int *indexPtr) +#} declare 37 { int Tcl_GetInt(Tcl_Interp *interp, const char *src, int *intPtr) } @@ -198,18 +200,20 @@ declare 48 { int Tcl_ListObjReplace(Tcl_Interp *interp, Tcl_Obj *listPtr, int first, int count, int objc, Tcl_Obj *const objv[]) } -declare 49 { - Tcl_Obj *Tcl_NewBooleanObj(int boolValue) -} +# Removed in 9.0: +#declare 49 { +# Tcl_Obj *Tcl_NewBooleanObj(int boolValue) +#} declare 50 { Tcl_Obj *Tcl_NewByteArrayObj(const unsigned char *bytes, int length) } declare 51 { Tcl_Obj *Tcl_NewDoubleObj(double doubleValue) } -declare 52 { - Tcl_Obj *Tcl_NewIntObj(int intValue) -} +# Removed in 9.0: +#declare 52 { +# Tcl_Obj *Tcl_NewIntObj(int intValue) +#} declare 53 { Tcl_Obj *Tcl_NewListObj(int objc, Tcl_Obj *const objv[]) } @@ -222,9 +226,10 @@ declare 55 { declare 56 { Tcl_Obj *Tcl_NewStringObj(const char *bytes, int length) } -declare 57 { - void Tcl_SetBooleanObj(Tcl_Obj *objPtr, int boolValue) -} +# Removed from 9.0: +#declare 57 { +# void Tcl_SetBooleanObj(Tcl_Obj *objPtr, int boolValue) +#} declare 58 { unsigned char *Tcl_SetByteArrayLength(Tcl_Obj *objPtr, int length) } @@ -235,9 +240,10 @@ declare 59 { declare 60 { void Tcl_SetDoubleObj(Tcl_Obj *objPtr, double doubleValue) } -declare 61 { - void Tcl_SetIntObj(Tcl_Obj *objPtr, int intValue) -} +# Removed in 9.0: +#declare 61 { +# void Tcl_SetIntObj(Tcl_Obj *objPtr, int intValue) +#} declare 62 { void Tcl_SetListObj(Tcl_Obj *objPtr, int objc, Tcl_Obj *const objv[]) } @@ -250,13 +256,15 @@ declare 64 { declare 65 { void Tcl_SetStringObj(Tcl_Obj *objPtr, const char *bytes, int length) } -declare 66 { - void Tcl_AddErrorInfo(Tcl_Interp *interp, const char *message) -} -declare 67 { - void Tcl_AddObjErrorInfo(Tcl_Interp *interp, const char *message, - int length) -} +# Removed in 9.0: +#declare 66 { +# void Tcl_AddErrorInfo(Tcl_Interp *interp, const char *message) +#} +# Removed in 9.0: +#declare 67 { +# void Tcl_AddObjErrorInfo(Tcl_Interp *interp, const char *message, +# int length) +#} declare 68 { void Tcl_AllowExceptions(Tcl_Interp *interp) } @@ -467,16 +475,18 @@ declare 127 { declare 128 { const char *Tcl_ErrnoMsg(int err) } -declare 129 { - int Tcl_Eval(Tcl_Interp *interp, const char *script) -} +# Removed in 9.0: +#declare 129 { +# int Tcl_Eval(Tcl_Interp *interp, const char *script) +#} # Removed in 9.0: #declare 130 { # int Tcl_EvalFile(Tcl_Interp *interp, const char *fileName) #} -declare 131 { - int Tcl_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr) -} +# Removed in 9.0: +#declare 131 { +# int Tcl_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr) +#} declare 132 { void Tcl_EventuallyFree(ClientData clientData, Tcl_FreeProc *freeProc) } @@ -627,10 +637,11 @@ declare 173 { declare 174 { const char *Tcl_GetStringResult(Tcl_Interp *interp) } -declare 175 { - const char *Tcl_GetVar(Tcl_Interp *interp, const char *varName, - int flags) -} +# Removed in 9.0 +#declare 175 { +# const char *Tcl_GetVar(Tcl_Interp *interp, const char *varName, +# int flags) +#} declare 176 { const char *Tcl_GetVar2(Tcl_Interp *interp, const char *part1, const char *part2, int flags) @@ -639,6 +650,7 @@ declare 176 { #declare 177 { # int Tcl_GlobalEval(Tcl_Interp *interp, const char *command) #} +# Removed in 9.0 #declare 178 { # int Tcl_GlobalEvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr) #} @@ -839,10 +851,11 @@ declare 235 { declare 236 { void Tcl_SetStdChannel(Tcl_Channel channel, int type) } -declare 237 { - const char *Tcl_SetVar(Tcl_Interp *interp, const char *varName, - const char *newValue, int flags) -} +# Removed in 9.0: +#declare 237 { +# const char *Tcl_SetVar(Tcl_Interp *interp, const char *varName, +# const char *newValue, int flags) +#} declare 238 { const char *Tcl_SetVar2(Tcl_Interp *interp, const char *part1, const char *part2, const char *newValue, int flags) @@ -875,10 +888,11 @@ declare 245 { #declare 246 { # int Tcl_TellOld(Tcl_Channel chan) #} -declare 247 { - int Tcl_TraceVar(Tcl_Interp *interp, const char *varName, int flags, - Tcl_VarTraceProc *proc, ClientData clientData) -} +# Removed in Tcl 9 +#declare 247 { +# int Tcl_TraceVar(Tcl_Interp *interp, const char *varName, int flags, +# Tcl_VarTraceProc *proc, ClientData clientData) +#} declare 248 { int Tcl_TraceVar2(Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *proc, ClientData clientData) @@ -896,17 +910,19 @@ declare 251 { declare 252 { int Tcl_UnregisterChannel(Tcl_Interp *interp, Tcl_Channel chan) } -declare 253 { - int Tcl_UnsetVar(Tcl_Interp *interp, const char *varName, int flags) -} +# Removed in 9.0: +#declare 253 { +# int Tcl_UnsetVar(Tcl_Interp *interp, const char *varName, int flags) +#} declare 254 { int Tcl_UnsetVar2(Tcl_Interp *interp, const char *part1, const char *part2, int flags) } -declare 255 { - void Tcl_UntraceVar(Tcl_Interp *interp, const char *varName, int flags, - Tcl_VarTraceProc *proc, ClientData clientData) -} +# Removed in 9.0: +#declare 255 { +# void Tcl_UntraceVar(Tcl_Interp *interp, const char *varName, int flags, +# Tcl_VarTraceProc *proc, ClientData clientData) +#} declare 256 { void Tcl_UntraceVar2(Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *proc, @@ -915,10 +931,11 @@ declare 256 { declare 257 { void Tcl_UpdateLinkedVar(Tcl_Interp *interp, const char *varName) } -declare 258 { - int Tcl_UpVar(Tcl_Interp *interp, const char *frameName, - const char *varName, const char *localName, int flags) -} +# Removed in 9.0 +#declare 258 { +# int Tcl_UpVar(Tcl_Interp *interp, const char *frameName, +# const char *varName, const char *localName, int flags) +#} declare 259 { int Tcl_UpVar2(Tcl_Interp *interp, const char *frameName, const char *part1, const char *part2, const char *localName, int flags) @@ -927,10 +944,11 @@ declare 259 { #declare 260 { # int Tcl_VarEval(Tcl_Interp *interp, ...) #} -declare 261 { - ClientData Tcl_VarTraceInfo(Tcl_Interp *interp, const char *varName, - int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData) -} +# Removed in 9.0 +#declare 261 { +# ClientData Tcl_VarTraceInfo(Tcl_Interp *interp, const char *varName, +# int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData) +#} declare 262 { ClientData Tcl_VarTraceInfo2(Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *procPtr, @@ -964,10 +982,11 @@ declare 270 { const char *Tcl_ParseVar(Tcl_Interp *interp, const char *start, const char **termPtr) } -declare 271 { - const char *Tcl_PkgPresent(Tcl_Interp *interp, const char *name, - const char *version, int exact) -} +# Removed in 9.0, converted to macro +#declare 271 { +# const char *Tcl_PkgPresent(Tcl_Interp *interp, const char *name, +# const char *version, int exact) +#} declare 272 { const char *Tcl_PkgPresentEx(Tcl_Interp *interp, const char *name, const char *version, int exact, @@ -979,10 +998,11 @@ declare 273 { const char *version) } # TIP #268: The internally used new Require function is in slot 573. -declare 274 { - const char *Tcl_PkgRequire(Tcl_Interp *interp, const char *name, - const char *version, int exact) -} +# Removed in 9.0, converted to macro +#declare 274 { +# const char *Tcl_PkgRequire(Tcl_Interp *interp, const char *name, +# const char *version, int exact) +#} # Removed in 9.0 #declare 275 { # void Tcl_SetErrorCodeVA(Tcl_Interp *interp, va_list argList) @@ -1054,9 +1074,10 @@ declare 288 { declare 289 { void Tcl_DeleteThreadExitHandler(Tcl_ExitProc *proc, ClientData clientData) } -declare 290 { - void Tcl_DiscardResult(Tcl_SavedResult *statePtr) -} +# Removed in 9.0: +#declare 290 { +# void Tcl_DiscardResult(Tcl_SavedResult *statePtr) +#} declare 291 { int Tcl_EvalEx(Tcl_Interp *interp, const char *script, int numBytes, int flags) @@ -1137,12 +1158,14 @@ declare 313 { int Tcl_ReadChars(Tcl_Channel channel, Tcl_Obj *objPtr, int charsToRead, int appendFlag) } -declare 314 { - void Tcl_RestoreResult(Tcl_Interp *interp, Tcl_SavedResult *statePtr) -} -declare 315 { - void Tcl_SaveResult(Tcl_Interp *interp, Tcl_SavedResult *statePtr) -} +# Removed in 9.0: +#declare 314 { +# void Tcl_RestoreResult(Tcl_Interp *interp, Tcl_SavedResult *statePtr) +#} +# Removed in 9.0: +#declare 315 { +# void Tcl_SaveResult(Tcl_Interp *interp, Tcl_SavedResult *statePtr) +#} declare 316 { int Tcl_SetSystemEncoding(Tcl_Interp *interp, const char *name) } diff --git a/generic/tcl.h b/generic/tcl.h index 98736ea..693b503 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -321,7 +321,7 @@ typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt; typedef struct _stat32i64 Tcl_StatBuf; # endif /* _MSC_VER < 1400 */ #elif defined(__CYGWIN__) - typedef struct _stat32i64 { + typedef struct { dev_t st_dev; unsigned short st_ino; unsigned short st_mode; @@ -337,7 +337,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; @@ -678,14 +678,11 @@ int Tcl_IsShared(Tcl_Obj *objPtr); /* *---------------------------------------------------------------------------- - * The following structure contains the state needed by Tcl_SaveResult. No-one - * outside of Tcl should access any of these fields. This structure is - * typically allocated on the stack. + * The following type contains the state needed by Tcl_SaveResult. This + * structure is typically allocated on the stack. */ -typedef struct Tcl_SavedResult { - Tcl_Obj *objResultPtr; -} Tcl_SavedResult; +typedef Tcl_Obj *Tcl_SavedResult; /* *---------------------------------------------------------------------------- @@ -2185,18 +2182,21 @@ typedef int (Tcl_NRPostProc) (ClientData data[], Tcl_Interp *interp, * main library in case an extension is statically linked into an application. */ -const char * TclInitStubs(Tcl_Interp *interp, const char *version, +const char * Tcl_InitStubs(Tcl_Interp *interp, const char *version, int exact, const char *tclversion, int magic); const char * TclTomMathInitializeStubs(Tcl_Interp *interp, const char *version, int epoch, int revision); -/* - * When not using stubs, make it a macro. - */ - #ifdef USE_TCL_STUBS -#define Tcl_InitStubs(interp, version, exact) \ - TclInitStubs(interp, version, exact, TCL_VERSION, TCL_STUB_MAGIC) +#if TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE +# define Tcl_InitStubs(interp, version, exact) \ + (Tcl_InitStubs)((interp), (version), (exact)|(int)sizeof(size_t), \ + TCL_VERSION, TCL_STUB_MAGIC) +#else +# define Tcl_InitStubs(interp, version, exact) \ + (Tcl_InitStubs)(interp, TCL_PATCH_LEVEL, 1|(int)sizeof(size_t), \ + TCL_VERSION, TCL_STUB_MAGIC) +#endif #else #define Tcl_InitStubs(interp, version, exact) \ Tcl_PkgInitStubsCheck(interp, version, exact) @@ -2328,9 +2328,6 @@ TCLAPI void Tcl_GetMemoryInfo(Tcl_DString *dsPtr); # undef Tcl_NewDoubleObj # define Tcl_NewDoubleObj(val) \ Tcl_DbNewDoubleObj(val, __FILE__, __LINE__) -# undef Tcl_NewIntObj -# define Tcl_NewIntObj(val) \ - Tcl_DbNewLongObj(val, __FILE__, __LINE__) # undef Tcl_NewListObj # define Tcl_NewListObj(objc, objv) \ Tcl_DbNewListObj(objc, objv, __FILE__, __LINE__) @@ -2394,18 +2391,6 @@ TCLAPI void Tcl_GetMemoryInfo(Tcl_DString *dsPtr); #define Tcl_ConditionFinalize(condPtr) #endif /* TCL_THREADS */ -/* - *---------------------------------------------------------------------------- - * Deprecated Tcl functions: - */ - -#ifndef TCL_NO_DEPRECATED -# undef Tcl_EvalObj -# define Tcl_EvalObj(interp,objPtr) \ - Tcl_EvalObjEx((interp),(objPtr),0) - -#endif /* !TCL_NO_DEPRECATED */ - #endif /* RC_INVOKED */ /* diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 7833105..5786975 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -798,12 +798,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; } @@ -841,16 +839,11 @@ CompileAssembleObj( CompileEnv compEnv; /* Compilation environment structure */ register ByteCode *codePtr = NULL; /* Bytecode resulting from the assembly */ - register const AuxData * auxDataPtr; - /* Pointer to an auxiliary data element - * in a compilation environment being - * destroyed. */ Namespace* namespacePtr; /* Namespace in which variable and command * names in the bytecode resolve */ int status; /* Status return from Tcl_AssembleCode */ const char* source; /* String representation of the source code */ int sourceLen; /* Length of the source code in bytes */ - int i; /* @@ -860,7 +853,7 @@ CompileAssembleObj( if (objPtr->typePtr == &assembleCodeType) { namespacePtr = iPtr->varFramePtr->nsPtr; - codePtr = objPtr->internalRep.otherValuePtr; + codePtr = objPtr->internalRep.twoPtrValue.ptr1; if (((Interp *) *codePtr->interpHandle == iPtr) && (codePtr->compileEpoch == iPtr->compileEpoch) && (codePtr->nsPtr == namespacePtr) @@ -888,44 +881,6 @@ CompileAssembleObj( /* * Assembly failed. Clean up and report the error. */ - - /* - * Free any literals that were constructed for the assembly. - */ - for (i = 0; i < compEnv.literalArrayNext; i++) { - TclReleaseLiteral(interp, compEnv.literalArrayPtr[i].objPtr); - } - - /* - * Free any auxiliary data that was attached to the bytecode - * under construction. - */ - - for (i = 0; i < compEnv.auxDataArrayNext; i++) { - auxDataPtr = compEnv.auxDataArrayPtr + i; - if (auxDataPtr->type->freeProc != NULL) { - (auxDataPtr->type->freeProc)(auxDataPtr->clientData); - } - } - - /* - * TIP 280. If there is extended command line information, - * we need to clean it up. - */ - - if (compEnv.extCmdMapPtr != NULL) { - if (compEnv.extCmdMapPtr->type == TCL_LOCATION_SOURCE) { - Tcl_DecrRefCount(compEnv.extCmdMapPtr->path); - } - for (i = 0; i < compEnv.extCmdMapPtr->nuloc; ++i) { - ckfree(compEnv.extCmdMapPtr->loc[i].line); - } - if (compEnv.extCmdMapPtr->loc != NULL) { - ckfree(compEnv.extCmdMapPtr->loc); - } - Tcl_DeleteHashTable(&(compEnv.extCmdMapPtr->litInfo)); - } - TclFreeCompileEnv(&compEnv); return NULL; } @@ -945,7 +900,7 @@ CompileAssembleObj( * Record the local variable context to which the bytecode pertains */ - codePtr = objPtr->internalRep.otherValuePtr; + codePtr = objPtr->internalRep.twoPtrValue.ptr1; if (iPtr->varFramePtr->localCachePtr) { codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; codePtr->localCachePtr->refCount++; @@ -4270,11 +4225,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"); } @@ -4338,14 +4293,13 @@ static void FreeAssembleCodeInternalRep( Tcl_Obj *objPtr) { - ByteCode *codePtr = objPtr->internalRep.otherValuePtr; + ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1; codePtr->refCount--; if (codePtr->refCount <= 0) { TclCleanupByteCode(codePtr); } objPtr->typePtr = NULL; - objPtr->internalRep.otherValuePtr = NULL; } /* diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 4f70cee..d31777e 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -146,10 +146,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 +3767,8 @@ TclNREvalObjv( int result; Namespace *lookupNsPtr = iPtr->lookupNsPtr; Command **cmdPtrPtr; - + NRE_callback *callbackPtr; + iPtr->lookupNsPtr = NULL; /* @@ -3783,15 +3781,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); @@ -3918,14 +3915,6 @@ TclNREvalObjv( } } -void -TclPushTailcallPoint( - Tcl_Interp *interp) -{ - TclNRAddCallback(interp, NRCommand, NULL, NULL, NULL, NULL); - ((Interp *) interp)->numLevels++; -} - int TclNRRunCallbacks( Tcl_Interp *interp, @@ -3962,6 +3951,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? @@ -4219,9 +4216,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); } @@ -5341,63 +5338,6 @@ TclArgumentGet( /* *---------------------------------------------------------------------- * - * Tcl_Eval -- - * - * Execute a Tcl command in a string. This function executes the script - * directly, rather than compiling it to bytecodes. Before the arrival of - * the bytecode compiler in Tcl 8.0 Tcl_Eval was the main function used - * for executing Tcl commands, but nowadays it isn't used much. - * - * Results: - * The return value is one of the return codes defined in tcl.h (such as - * TCL_OK), and interp's result contains a value to supplement the return - * code. The value of the result will persist only until the next call to - * Tcl_Eval or Tcl_EvalObj: you must copy it or lose it! - * - * Side effects: - * Can be almost arbitrary, depending on the commands in the script. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_Eval( - Tcl_Interp *interp, /* Token for command interpreter (returned by - * previous call to Tcl_CreateInterp). */ - const char *script) /* Pointer to TCL command to execute. */ -{ - return Tcl_EvalEx(interp, script, -1, 0); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_EvalObj -- - * - * These functions are deprecated but we keep them around for backwards - * compatibility reasons. - * - * Results: - * See the functions they call. - * - * Side effects: - * See the functions they call. - * - *---------------------------------------------------------------------- - */ - -#undef Tcl_EvalObj -int -Tcl_EvalObj( - Tcl_Interp *interp, - Tcl_Obj *objPtr) -{ - return Tcl_EvalObjEx(interp, objPtr, 0); -} - -/* - *---------------------------------------------------------------------- - * * Tcl_EvalObjEx, TclEvalObjEx -- * * Execute Tcl commands stored in a Tcl object. These commands are @@ -5541,7 +5481,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); @@ -6261,72 +6202,10 @@ Tcl_AppendObjToErrorInfo( Tcl_Obj *objPtr) /* Message to record. */ { int length; + register Interp *iPtr = (Interp *) interp; const char *message = TclGetStringFromObj(objPtr, &length); Tcl_IncrRefCount(objPtr); - Tcl_AddObjErrorInfo(interp, message, length); - Tcl_DecrRefCount(objPtr); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_AddErrorInfo -- - * - * Add information to the errorInfo field that describes the current - * error. - * - * Results: - * None. - * - * Side effects: - * The contents of message are appended to the errorInfo field. If we are - * just starting to log an error, errorInfo is initialized from the error - * message in the interpreter's result. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_AddErrorInfo( - Tcl_Interp *interp, /* Interpreter to which error information - * pertains. */ - const char *message) /* Message to record. */ -{ - Tcl_AddObjErrorInfo(interp, message, -1); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_AddObjErrorInfo -- - * - * Add information to the errorInfo field that describes the current - * error. This routine differs from Tcl_AddErrorInfo by taking a byte - * pointer and length. - * - * Results: - * None. - * - * Side effects: - * "length" bytes from "message" are appended to the errorInfo field. If - * "length" is negative, use bytes up to the first NULL byte. If we are - * just starting to log an error, errorInfo is initialized from the error - * message in the interpreter's result. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_AddObjErrorInfo( - Tcl_Interp *interp, /* Interpreter to which error information - * pertains. */ - const char *message, /* Points to the first byte of an array of - * bytes of the message. */ - int length) /* The number of bytes in the message. If < 0, - * then append all bytes up to a NULL byte. */ -{ - register Interp *iPtr = (Interp *) interp; /* * If we are just starting to log an error, errorInfo is initialized from @@ -6354,6 +6233,7 @@ Tcl_AddObjErrorInfo( } Tcl_AppendToObj(iPtr->errorInfo, message, length); } + Tcl_DecrRefCount(objPtr); } /* @@ -7650,29 +7530,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 @@ -7702,7 +7611,7 @@ TclNRTailcallObjCmd( */ if (iPtr->varFramePtr->tailcallPtr) { - ClearTailcall(interp, iPtr->varFramePtr->tailcallPtr); + Tcl_DecrRefCount(iPtr->varFramePtr->tailcallPtr); iPtr->varFramePtr->tailcallPtr = NULL; } @@ -7717,23 +7626,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; } @@ -7745,12 +7651,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); } @@ -7769,10 +7677,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 @@ -7782,19 +7690,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( @@ -7896,50 +7794,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( diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 5c33308..4f60ac8 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 @@ -167,7 +191,7 @@ const Tcl_ObjType tclByteArrayType = { * fewer mallocs. */ -typedef struct ByteArray { +typedef struct { int used; /* The number of bytes used in the byte * array. */ int allocated; /* The amount of space actually allocated @@ -180,9 +204,10 @@ typedef struct ByteArray { #define BYTEARRAY_SIZE(len) \ ((unsigned) (TclOffset(ByteArray, bytes) + (len))) #define GET_BYTEARRAY(objPtr) \ - ((ByteArray *) (objPtr)->internalRep.otherValuePtr) + ((ByteArray *) (objPtr)->internalRep.twoPtrValue.ptr1) #define SET_BYTEARRAY(objPtr, baPtr) \ - (objPtr)->internalRep.otherValuePtr = (void *) (baPtr) + (objPtr)->internalRep.twoPtrValue.ptr1 = (void *) (baPtr) + /* *---------------------------------------------------------------------- @@ -301,7 +326,7 @@ Tcl_SetByteArrayObj( Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayObj"); } TclFreeIntRep(objPtr); - Tcl_InvalidateStringRep(objPtr); + TclInvalidateStringRep(objPtr); if (length < 0) { length = 0; @@ -396,7 +421,7 @@ Tcl_SetByteArrayLength( byteArrayPtr->allocated = length; SET_BYTEARRAY(objPtr, byteArrayPtr); } - Tcl_InvalidateStringRep(objPtr); + TclInvalidateStringRep(objPtr); byteArrayPtr->used = length; return byteArrayPtr->bytes; } @@ -667,7 +692,7 @@ TclAppendBytesToByteArray( if (len > 0) { memcpy(byteArrayPtr->bytes + byteArrayPtr->used, bytes, len); byteArrayPtr->used += len; - Tcl_InvalidateStringRep(objPtr); + TclInvalidateStringRep(objPtr); } } @@ -688,26 +713,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,12 +2362,12 @@ 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) { - if (Tcl_GetIndexFromObj(interp, objv[i], optStrings, "option", - TCL_EXACT, &index) != TCL_OK) { + if (Tcl_GetIndexFromObjStruct(interp, objv[i], optStrings, + sizeof(char *), "option", TCL_EXACT, &index) != TCL_OK) { return TCL_ERROR; } switch (index) { @@ -2481,8 +2486,8 @@ BinaryEncode64( return TCL_ERROR; } for (i = 1; i < objc-1; i += 2) { - if (Tcl_GetIndexFromObj(interp, objv[i], optStrings, "option", - TCL_EXACT, &index) != TCL_OK) { + if (Tcl_GetIndexFromObjStruct(interp, objv[i], optStrings, + sizeof(char *), "option", TCL_EXACT, &index) != TCL_OK) { return TCL_ERROR; } switch (index) { @@ -2571,12 +2576,12 @@ 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) { - if (Tcl_GetIndexFromObj(interp, objv[i], optStrings, "option", - TCL_EXACT, &index) != TCL_OK) { + if (Tcl_GetIndexFromObjStruct(interp, objv[i], optStrings, + sizeof(char *), "option", TCL_EXACT, &index) != TCL_OK) { return TCL_ERROR; } switch (index) { @@ -2667,12 +2672,12 @@ 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) { - if (Tcl_GetIndexFromObj(interp, objv[i], optStrings, "option", - TCL_EXACT, &index) != TCL_OK) { + if (Tcl_GetIndexFromObjStruct(interp, objv[i], optStrings, + sizeof(char *), "option", TCL_EXACT, &index) != TCL_OK) { return TCL_ERROR; } switch (index) { diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c index ab977cb..ede0d67 100644 --- a/generic/tclCkalloc.c +++ b/generic/tclCkalloc.c @@ -33,7 +33,7 @@ * "memory tag" command is invoked, to hold the current tag. */ -typedef struct MemTag { +typedef struct { int refCount; /* Number of mem_headers referencing this * tag. */ char string[1]; /* Actual size of string will be as large as @@ -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/tclClock.c b/generic/tclClock.c index 6d2976d..98ca02d 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -91,7 +91,7 @@ static const char *const literals[] = { * Structure containing the client data for [clock] */ -typedef struct ClockClientData { +typedef struct { int refCount; /* Number of live references. */ Tcl_Obj **literals; /* Pool of object literals. */ } ClockClientData; @@ -100,7 +100,7 @@ typedef struct ClockClientData { * Structure containing the fields used in [clock format] and [clock scan] */ -typedef struct TclDateFields { +typedef struct { Tcl_WideInt seconds; /* Time expressed in seconds from the Posix * epoch */ Tcl_WideInt localSeconds; /* Local time expressed in nominal seconds @@ -548,8 +548,8 @@ ClockGetjuliandayfromerayearmonthdayObjCmd( } dict = objv[1]; if (Tcl_DictObjGet(interp, dict, literals[LIT_ERA], &fieldPtr) != TCL_OK - || Tcl_GetIndexFromObj(interp, fieldPtr, eras, "era", TCL_EXACT, - &era) != TCL_OK + || Tcl_GetIndexFromObjStruct(interp, fieldPtr, eras, + sizeof(char *), "era", TCL_EXACT, &era) != TCL_OK || Tcl_DictObjGet(interp, dict, literals[LIT_YEAR], &fieldPtr) != TCL_OK || TclGetIntFromObj(interp, fieldPtr, &fields.year) != TCL_OK @@ -638,8 +638,8 @@ ClockGetjuliandayfromerayearweekdayObjCmd( } dict = objv[1]; if (Tcl_DictObjGet(interp, dict, literals[LIT_ERA], &fieldPtr) != TCL_OK - || Tcl_GetIndexFromObj(interp, fieldPtr, eras, "era", TCL_EXACT, - &era) != TCL_OK + || Tcl_GetIndexFromObjStruct(interp, fieldPtr, eras, + sizeof(char *), "era", TCL_EXACT, &era) != TCL_OK || Tcl_DictObjGet(interp, dict, literals[LIT_ISO8601YEAR], &fieldPtr) != TCL_OK || TclGetIntFromObj(interp, fieldPtr, &fields.iso8601Year)!=TCL_OK @@ -1697,8 +1697,8 @@ ClockClicksObjCmd( case 1: break; case 2: - if (Tcl_GetIndexFromObj(interp, objv[1], clicksSwitches, "switch", 0, - &index) != TCL_OK) { + if (Tcl_GetIndexFromObjStruct(interp, objv[1], clicksSwitches, + sizeof(char *), "switch", 0, &index) != TCL_OK) { return TCL_ERROR; } break; @@ -1867,8 +1867,8 @@ ClockParseformatargsObjCmd( localeObj = litPtr[LIT_C]; timezoneObj = litPtr[LIT__NIL]; for (i = 2; i < objc; i+=2) { - if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", 0, - &optionIndex) != TCL_OK) { + if (Tcl_GetIndexFromObjStruct(interp, objv[i], options, + sizeof(char *), "switch", 0, &optionIndex) != TCL_OK) { Tcl_SetErrorCode(interp, "CLOCK", "badSwitch", Tcl_GetString(objv[i]), NULL); return TCL_ERROR; diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 4be8b2a..fd62ede 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -395,8 +395,8 @@ Tcl_EncodingObjCmd( Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); return TCL_ERROR; } - if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0, - &index) != TCL_OK) { + if (Tcl_GetIndexFromObjStruct(interp, objv[1], optionStrings, + sizeof(char *), "option", 0, &index) != TCL_OK) { return TCL_ERROR; } @@ -612,7 +612,7 @@ Tcl_EvalObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - return Tcl_NRCallObjProc(interp, TclNREvalObjCmd, dummy, objc, objv); + return Tcl_NRCallObjProc(interp, TclNREvalObjCmd, dummy, objc, objv); } int @@ -813,40 +813,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..7fdab05 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -56,7 +56,7 @@ typedef int (*SortMemCmpFn_t) (const void *, const void *, size_t); * The following structure is used to pass this information. */ -typedef struct SortInfo { +typedef struct { int isIncreasing; /* Nonzero means sort in increasing order. */ int sortMode; /* The sort mode. One of SORTMODE_* values * defined below. */ @@ -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} }; @@ -2962,8 +2962,8 @@ Tcl_LsearchObjCmd( } for (i = 1; i < objc-2; i++) { - if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index) - != TCL_OK) { + if (Tcl_GetIndexFromObjStruct(interp, objv[i], options, + sizeof(char *), "option", 0, &index) != TCL_OK) { if (startPtr != NULL) { Tcl_DecrRefCount(startPtr); } @@ -3691,8 +3691,8 @@ Tcl_LsortObjCmd( groupOffset = 0; indexPtr = NULL; for (i = 1; i < objc-1; i++) { - if (Tcl_GetIndexFromObj(interp, objv[i], switches, "option", 0, - &index) != TCL_OK) { + if (Tcl_GetIndexFromObjStruct(interp, objv[i], switches, + sizeof(char *), "option", 0, &index) != TCL_OK) { sortInfo.resultCode = TCL_ERROR; goto done2; } diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index fc957c4..9c67fbf 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -159,8 +159,8 @@ Tcl_RegexpObjCmd( if (name[0] != '-') { break; } - if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", TCL_EXACT, - &index) != TCL_OK) { + if (Tcl_GetIndexFromObjStruct(interp, objv[i], options, + sizeof(char *), "switch", TCL_EXACT, &index) != TCL_OK) { goto optionError; } switch ((enum options) index) { @@ -335,7 +335,7 @@ Tcl_RegexpObjCmd( */ if (!doinline) { - Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); + Tcl_SetObjResult(interp, Tcl_NewLongObj(0)); } return TCL_OK; } @@ -457,7 +457,7 @@ Tcl_RegexpObjCmd( if (doinline) { Tcl_SetObjResult(interp, resultPtr); } else { - Tcl_SetObjResult(interp, Tcl_NewIntObj(all ? all-1 : 1)); + Tcl_SetObjResult(interp, Tcl_NewLongObj(all ? all-1 : 1)); } return TCL_OK; } @@ -517,8 +517,8 @@ Tcl_RegsubObjCmd( if (name[0] != '-') { break; } - if (Tcl_GetIndexFromObj(interp, objv[idx], options, "switch", - TCL_EXACT, &index) != TCL_OK) { + if (Tcl_GetIndexFromObjStruct(interp, objv[idx], options, + sizeof(char *), "switch", TCL_EXACT, &index) != TCL_OK) { goto optionError; } switch ((enum options) index) { @@ -847,7 +847,7 @@ Tcl_RegsubObjCmd( * holding the number of matches. */ - Tcl_SetObjResult(interp, Tcl_NewIntObj(numMatches)); + Tcl_SetObjResult(interp, Tcl_NewLongObj(numMatches)); } } else { /* @@ -1003,8 +1003,8 @@ TclNRSourceObjCmd( }; int index; - if (TCL_ERROR == Tcl_GetIndexFromObj(interp, objv[1], options, - "option", TCL_EXACT, &index)) { + if (TCL_ERROR == Tcl_GetIndexFromObjStruct(interp, objv[1], options, + sizeof(char *), "option", TCL_EXACT, &index)) { return TCL_ERROR; } encodingName = TclGetString(objv[2]); @@ -1260,7 +1260,7 @@ StringFirstCmd( } str_first_done: - Tcl_SetObjResult(interp, Tcl_NewIntObj(match)); + Tcl_SetObjResult(interp, Tcl_NewLongObj(match)); return TCL_OK; } @@ -1358,7 +1358,7 @@ StringLastCmd( } str_last_done: - Tcl_SetObjResult(interp, Tcl_NewIntObj(match)); + Tcl_SetObjResult(interp, Tcl_NewLongObj(match)); return TCL_OK; } @@ -1485,8 +1485,8 @@ StringIsCmd( "class ?-strict? ?-failindex var? str"); return TCL_ERROR; } - if (Tcl_GetIndexFromObj(interp, objv[1], isClasses, "class", 0, - &index) != TCL_OK) { + if (Tcl_GetIndexFromObjStruct(interp, objv[1], isClasses, + sizeof(char *), "class", 0, &index) != TCL_OK) { return TCL_ERROR; } @@ -1494,8 +1494,8 @@ StringIsCmd( for (i = 2; i < objc-1; i++) { int idx2; - if (Tcl_GetIndexFromObj(interp, objv[i], isOptions, "option", 0, - &idx2) != TCL_OK) { + if (Tcl_GetIndexFromObjStruct(interp, objv[i], isOptions, + sizeof(char *), "option", 0, &idx2) != TCL_OK) { return TCL_ERROR; } switch ((enum isOptions) idx2) { @@ -1540,7 +1540,8 @@ StringIsCmd( case STR_IS_BOOL: case STR_IS_TRUE: case STR_IS_FALSE: - if (TCL_OK != Tcl_ConvertToType(NULL, objPtr, &tclBooleanType)) { + if ((objPtr->typePtr != &tclBooleanType) + && (TCL_OK != TclSetBooleanFromAny(NULL, objPtr))) { if (strict) { result = 0; } else { @@ -1797,11 +1798,11 @@ StringIsCmd( str_is_done: if ((result == 0) && (failVarObj != NULL) && - Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewIntObj(failat), + Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewLongObj(failat), TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result)); + Tcl_SetObjResult(interp, Tcl_NewLongObj(result!=0)); return TCL_OK; } @@ -2136,8 +2137,8 @@ StringMatchCmd( return TCL_ERROR; } } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj( - TclStringMatchObj(objv[objc-1], objv[objc-2], nocase))); + Tcl_SetObjResult(interp, Tcl_NewLongObj( + TclStringMatchObj(objv[objc-1], objv[objc-2], nocase)!=0)); return TCL_OK; } @@ -2467,7 +2468,7 @@ StringStartCmd( cur += 1; } } - Tcl_SetObjResult(interp, Tcl_NewIntObj(cur)); + Tcl_SetObjResult(interp, Tcl_NewLongObj(cur)); return TCL_OK; } @@ -2529,7 +2530,7 @@ StringEndCmd( } else { cur = numChars; } - Tcl_SetObjResult(interp, Tcl_NewIntObj(cur)); + Tcl_SetObjResult(interp, Tcl_NewLongObj(cur)); return TCL_OK; } @@ -2611,7 +2612,7 @@ StringEqualCmd( * Always match at 0 chars of if it is the same obj. */ - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(1)); + Tcl_SetObjResult(interp, Tcl_NewLongObj(1)); return TCL_OK; } @@ -2679,7 +2680,7 @@ StringEqualCmd( } } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(match ? 0 : 1)); + Tcl_SetObjResult(interp, Tcl_NewLongObj(match==0)); return TCL_OK; } @@ -2761,7 +2762,7 @@ StringCmpCmd( * Always match at 0 chars of if it is the same obj. */ - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); + Tcl_SetObjResult(interp, Tcl_NewLongObj(0)); return TCL_OK; } @@ -2826,7 +2827,7 @@ StringCmpCmd( } Tcl_SetObjResult(interp, - Tcl_NewIntObj((match > 0) ? 1 : (match < 0) ? -1 : 0)); + Tcl_NewLongObj((match > 0) ? 1 : (match < 0) ? -1 : 0)); return TCL_OK; } @@ -2864,7 +2865,7 @@ StringBytesCmd( } (void) TclGetStringFromObj(objv[1], &length); - Tcl_SetObjResult(interp, Tcl_NewIntObj(length)); + Tcl_SetObjResult(interp, Tcl_NewLongObj(length)); return TCL_OK; } @@ -2898,7 +2899,7 @@ StringLenCmd( return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_GetCharLength(objv[1]))); + Tcl_SetObjResult(interp, Tcl_NewLongObj(Tcl_GetCharLength(objv[1]))); return TCL_OK; } @@ -3324,7 +3325,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 +3336,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} }; @@ -3388,8 +3389,8 @@ TclSubstOptions( for (i = 0; i < numOpts; i++) { int optionIndex; - if (Tcl_GetIndexFromObj(interp, opts[i], substOptions, "switch", 0, - &optionIndex) != TCL_OK) { + if (Tcl_GetIndexFromObjStruct(interp, opts[i], substOptions, + sizeof(char *), "switch", 0, &optionIndex) != TCL_OK) { return TCL_ERROR; } switch (optionIndex) { @@ -3513,8 +3514,8 @@ TclNRSwitchObjCmd( if (TclGetString(objv[i])[0] != '-') { break; } - if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, - &index) != TCL_OK) { + if (Tcl_GetIndexFromObjStruct(interp, objv[i], options, + sizeof(char *), "option", 0, &index) != TCL_OK) { return TCL_ERROR; } switch ((enum options) index) { @@ -3790,7 +3791,7 @@ TclNRSwitchObjCmd( rangeObjAry[0] = Tcl_NewLongObj(info.matches[j].start); rangeObjAry[1] = Tcl_NewLongObj(info.matches[j].end-1); } else { - rangeObjAry[0] = rangeObjAry[1] = Tcl_NewIntObj(-1); + rangeObjAry[0] = rangeObjAry[1] = Tcl_NewLongObj(-1); } /* @@ -4110,7 +4111,7 @@ Tcl_TimeObjCmd( * Use int obj since we know time is not fractional. [Bug 1202178] */ - objs[0] = Tcl_NewIntObj((count <= 0) ? 0 : (int) totalMicroSec); + objs[0] = Tcl_NewLongObj((count <= 0) ? 0 : (int) totalMicroSec); } else { objs[0] = Tcl_NewDoubleObj(totalMicroSec/count); } @@ -4190,8 +4191,8 @@ TclNRTryObjCmd( int type; Tcl_Obj *info[5]; - if (Tcl_GetIndexFromObj(interp, objv[i], handlerNames, "handler type", - 0, &type) != TCL_OK) { + if (Tcl_GetIndexFromObjStruct(interp, objv[i], handlerNames, + sizeof(char *), "handler type", 0, &type) != TCL_OK) { Tcl_DecrRefCount(handlersObj); return TCL_ERROR; } @@ -4264,7 +4265,7 @@ TclNRTryObjCmd( } info[0] = objv[i]; /* type */ - TclNewIntObj(info[1], code); /* returnCode */ + TclNewLongObj(info[1], code); /* returnCode */ if (info[2] == NULL) { /* errorCodePrefix */ TclNewObj(info[2]); } diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 160fa3c..40348fa 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -107,6 +107,7 @@ static int CompileDictEachCmd(Tcl_Interp *interp, */ #define TCL_NO_LARGE_INDEX 1 /* Do not return localIndex value > 255 */ +#define TCL_NO_ELEMENT 2 /* Do not push the array element. */ /* * The structures below define the AuxData types defined in this file. @@ -259,7 +260,7 @@ TclCompileArrayExistsCmd( } tokenPtr = TokenAfter(parsePtr->tokenPtr); - PushVarNameWord(interp, tokenPtr, envPtr, 0, + PushVarNameWord(interp, tokenPtr, envPtr, TCL_NO_ELEMENT, &localIndex, &simpleVarName, &isScalar, 1); if (!isScalar) { return TCL_ERROR; @@ -283,7 +284,7 @@ TclCompileArraySetCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ - Tcl_Token *tokenPtr; + Tcl_Token *varTokenPtr, *dataTokenPtr; int simpleVarName, isScalar, localIndex; int dataVar, iterVar, keyVar, valVar, infoIndex; int back, fwd, offsetBack, offsetFwd, savedStackDepth; @@ -293,20 +294,21 @@ TclCompileArraySetCmd( return TCL_ERROR; } - tokenPtr = TokenAfter(parsePtr->tokenPtr); - PushVarNameWord(interp, tokenPtr, envPtr, 0, + varTokenPtr = TokenAfter(parsePtr->tokenPtr); + PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_ELEMENT, &localIndex, &simpleVarName, &isScalar, 1); + dataTokenPtr = TokenAfter(varTokenPtr); if (!isScalar) { return TCL_ERROR; } - tokenPtr = TokenAfter(tokenPtr); /* * Special case: literal empty value argument is just an "ensure array" * operation. */ - if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD && tokenPtr[1].size == 0) { + if (dataTokenPtr->type == TCL_TOKEN_SIMPLE_WORD + && dataTokenPtr[1].size == 0) { if (localIndex >= 0) { TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr); TclEmitInstInt1(INST_JUMP_TRUE1, 7, envPtr); @@ -329,14 +331,37 @@ TclCompileArraySetCmd( * Prepare for the internal foreach. */ - if (envPtr->procPtr == NULL) { - return TCL_ERROR; - } dataVar = TclFindCompiledLocal(NULL, 0, 1, envPtr); iterVar = TclFindCompiledLocal(NULL, 0, 1, envPtr); keyVar = TclFindCompiledLocal(NULL, 0, 1, envPtr); valVar = TclFindCompiledLocal(NULL, 0, 1, envPtr); + if (dataVar < 0) { + /* + * 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, TclFetchLiteral(envPtr, cmdLit), cmdPtr); + TclEmitPush(cmdLit, envPtr); + TclDecrRefCount(objPtr); + if (localIndex >= 0) { + CompileWord(envPtr, varTokenPtr, interp, 1); + } else { + TclEmitInstInt4(INST_REVERSE, 2, envPtr); + } + CompileWord(envPtr, dataTokenPtr, interp, 2); + TclEmitInstInt1(INST_INVOKE_STK1, 3, envPtr); + return TCL_OK; + } + infoPtr = ckalloc(sizeof(ForeachInfo) + sizeof(ForeachVarList *)); infoPtr->numLists = 1; infoPtr->firstValueTemp = dataVar; @@ -351,7 +376,7 @@ TclCompileArraySetCmd( * Start issuing instructions to write to the array. */ - CompileWord(envPtr, tokenPtr, interp, 2); + CompileWord(envPtr, dataTokenPtr, interp, 2); TclEmitOpcode( INST_DUP, envPtr); TclEmitOpcode( INST_LIST_LENGTH, envPtr); PushLiteral(envPtr, "1", 1); @@ -434,10 +459,10 @@ TclCompileArrayUnsetCmd( int simpleVarName, isScalar, localIndex, savedStackDepth; if (parsePtr->numWords != 2) { - return TCL_ERROR; + return TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr); } - PushVarNameWord(interp, tokenPtr, envPtr, 0, + PushVarNameWord(interp, tokenPtr, envPtr, TCL_NO_ELEMENT, &localIndex, &simpleVarName, &isScalar, 1); if (!isScalar) { return TCL_ERROR; @@ -928,7 +953,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; @@ -938,7 +963,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; @@ -951,16 +976,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); } /* @@ -1078,16 +1103,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); } /* @@ -1178,7 +1203,7 @@ TclCompileDictCreateCmd( nonConstant: worker = TclFindCompiledLocal(NULL, 0, 1, envPtr); if (worker < 0) { - return TCL_ERROR; + return TclCompileBasicMin0ArgCmd(interp, parsePtr, cmdPtr, envPtr); } PushLiteral(envPtr, "", 0); @@ -1239,7 +1264,7 @@ TclCompileDictMergeCmd( workerIndex = TclFindCompiledLocal(NULL, 0, 1, envPtr); if (workerIndex < 0) { - return TCL_ERROR; + return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr); } infoIndex = TclFindCompiledLocal(NULL, 0, 1, envPtr); @@ -1365,11 +1390,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); @@ -1377,7 +1402,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); } /* @@ -1389,7 +1414,7 @@ CompileDictEachCmd( collectVar = TclFindCompiledLocal(NULL, /*nameChars*/ 0, /*create*/ 1, envPtr); if (collectVar < 0) { - return TCL_ERROR; + return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } } @@ -1403,31 +1428,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); } /* @@ -1439,7 +1464,7 @@ CompileDictEachCmd( infoIndex = TclFindCompiledLocal(NULL, 0, 1, envPtr); if (infoIndex < 0) { - return TCL_ERROR; + return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } /* @@ -1636,16 +1661,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); } /* @@ -1696,7 +1721,7 @@ TclCompileDictUpdateCmd( failedUpdateInfoAssembly: ckfree(duiPtr); TclStackFree(interp, keyTokenPtrs); - return TCL_ERROR; + return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr); } bodyTokenPtr = tokenPtr; @@ -1794,17 +1819,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); } } @@ -1855,16 +1880,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); } CompileWord(envPtr, keyTokenPtr, interp, 3); CompileWord(envPtr, valueTokenPtr, interp, 4); @@ -1908,7 +1933,7 @@ TclCompileDictWithCmd( tokenPtr = TokenAfter(tokenPtr); } if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; + return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr); } /* @@ -1920,7 +1945,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; @@ -3082,7 +3108,7 @@ TclCompileFormatCmd( * after our attempt to spot a literal). */ - for (; --i>=0 ;) { + for (; i>=0 ; i--) { Tcl_DecrRefCount(objv[i]); } ckfree(objv); @@ -3747,7 +3773,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); @@ -3784,7 +3812,7 @@ TclCompileInfoCommandsCmd( notCompilable: Tcl_DecrRefCount(objPtr); - return TCL_ERROR; + return TclCompileBasic1ArgCmd(interp, parsePtr, cmdPtr, envPtr); } int @@ -5791,7 +5819,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); @@ -5801,15 +5829,15 @@ TclCompileVariableCmd( return TCL_ERROR; } - CompileWord(envPtr, varTokenPtr, interp, 1); + CompileWord(envPtr, varTokenPtr, interp, i); TclEmitInstInt4( INST_VARIABLE, localIndex, envPtr); - if (i != numWords) { + if (i+1 < numWords) { /* * A value has been given: set the variable, pop the value */ - CompileWord(envPtr, valueTokenPtr, interp, 1); + CompileWord(envPtr, valueTokenPtr, interp, i+1); Emit14Inst( INST_STORE_SCALAR, localIndex, envPtr); TclEmitOpcode( INST_POP, envPtr); } @@ -6006,7 +6034,7 @@ PushVarName( 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. */ @@ -6187,10 +6215,11 @@ PushVarName( } /* - * Compile the element script, if any. + * Compile the element script, if any, and only if not inhibited. [Bug + * 3600328] */ - if (elName != NULL) { + if (elName != NULL && !(flags & TCL_NO_ELEMENT)) { if (elNameChars) { envPtr->line = line; envPtr->clNext = clNext; diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 9c93fb2..f73beca 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -448,7 +448,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; @@ -457,7 +457,7 @@ TclCompileStringMatchCmd( * Fail at run time, not in compilation. */ - return TCL_ERROR; + return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } nocase = 1; tokenPtr = TokenAfter(tokenPtr); @@ -578,13 +578,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); } /* @@ -836,6 +836,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) { @@ -1925,11 +1953,13 @@ TclCompileTailcallCmd( return TCL_ERROR; } + /* make room for the nsObjPtr */ + CompileWord(envPtr, tokenPtr, interp, 0); for (i=1 ; i<parsePtr->numWords ; i++) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, i); } - TclEmitInstInt1( INST_TAILCALL, parsePtr->numWords-1, envPtr); + TclEmitInstInt1( INST_TAILCALL, parsePtr->numWords, envPtr); return TCL_OK; } @@ -2709,7 +2739,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/tclCompExpr.c b/generic/tclCompExpr.c index 890d518..2062dc8 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -22,7 +22,7 @@ * The tree is composed of OpNodes. */ -typedef struct OpNode { +typedef struct { int left; /* "Pointer" to the left operand. */ int right; /* "Pointer" to the right operand. */ union { @@ -2207,7 +2207,7 @@ ExecConstantExprTree( TclInitByteCodeObj(byteCodeObj, envPtr); TclFreeCompileEnv(envPtr); TclStackFree(interp, envPtr); - byteCodePtr = byteCodeObj->internalRep.otherValuePtr; + byteCodePtr = byteCodeObj->internalRep.twoPtrValue.ptr1; TclNRExecuteByteCode(interp, byteCodePtr); code = TclNRRunCallbacks(interp, TCL_OK, rootPtr); Tcl_DecrRefCount(byteCodeObj); @@ -2445,14 +2445,11 @@ CompileExprTree( Tcl_Obj *literal = *litObjv; if (optimize) { - int length, index; + int length; const char *bytes = TclGetStringFromObj(literal, &length); - LiteralEntry *lePtr; - Tcl_Obj *objPtr; - - index = TclRegisterNewLiteral(envPtr, bytes, length); - lePtr = envPtr->literalArrayPtr + index; - objPtr = lePtr->objPtr; + int index = TclRegisterNewLiteral(envPtr, bytes, length); + Tcl_Obj *objPtr = TclFetchLiteral(envPtr, index); + if ((objPtr->typePtr == NULL) && (literal->typePtr != NULL)) { /* * Would like to do this: @@ -2511,7 +2508,7 @@ CompileExprTree( index = TclRegisterNewLiteral(envPtr, objPtr->bytes, objPtr->length); - tableValue = envPtr->literalArrayPtr[index].objPtr; + tableValue = TclFetchLiteral(envPtr, index); if ((tableValue->typePtr == NULL) && (objPtr->typePtr != NULL)) { /* diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 309682d..5427759 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -529,6 +529,11 @@ InstructionDesc const tclInstructionTable[] = { /* Forces the variable indexed by opnd to be an array. Does not touch * the stack. */ + {"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}} }; @@ -552,6 +557,7 @@ static int GetCmdLocEncodingSize(CompileEnv *envPtr); #ifdef TCL_COMPILE_STATS static void RecordByteCodeStats(ByteCode *codePtr); #endif /* TCL_COMPILE_STATS */ +static void RegisterAuxDataType(const AuxDataType *typePtr); static int SetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static int FormatInstruction(ByteCode *codePtr, @@ -568,6 +574,7 @@ static void EnterCmdWordData(ExtCmdLoc *eclPtr, int srcOffset, Tcl_Token *tokenPtr, const char *cmd, int len, int numWords, int line, int *clNext, int **lines, CompileEnv *envPtr); +static void ReleaseCmdWordData(ExtCmdLoc *eclPtr); /* * The structure below defines the bytecode Tcl object type by means of @@ -645,9 +652,6 @@ TclSetByteCodeFromAny( Interp *iPtr = (Interp *) interp; CompileEnv compEnv; /* Compilation environment structure allocated * in frame. */ - register const AuxData *auxDataPtr; - LiteralEntry *entryPtr; - register int i; int length, result = TCL_OK; const char *stringPtr; ContLineLoc *clLocPtr; @@ -717,35 +721,14 @@ TclSetByteCodeFromAny( TclVerifyLocalLiteralTable(&compEnv); #endif /*TCL_COMPILE_DEBUG*/ - TclInitByteCodeObj(objPtr, &compEnv); -#ifdef TCL_COMPILE_DEBUG - if (tclTraceCompile >= 2) { - TclPrintByteCodeObj(interp, objPtr); - fflush(stdout); - } -#endif /* TCL_COMPILE_DEBUG */ - - if (result != TCL_OK) { - /* - * Handle any error from the hookProc - */ - - entryPtr = compEnv.literalArrayPtr; - for (i = 0; i < compEnv.literalArrayNext; i++) { - TclReleaseLiteral(interp, entryPtr->objPtr); - entryPtr++; - } + if (result == TCL_OK) { + TclInitByteCodeObj(objPtr, &compEnv); #ifdef TCL_COMPILE_DEBUG - TclVerifyGlobalLiteralTable(iPtr); -#endif /*TCL_COMPILE_DEBUG*/ - - auxDataPtr = compEnv.auxDataArrayPtr; - for (i = 0; i < compEnv.auxDataArrayNext; i++) { - if (auxDataPtr->type->freeProc != NULL) { - auxDataPtr->type->freeProc(auxDataPtr->clientData); - } - auxDataPtr++; + if (tclTraceCompile >= 2) { + TclPrintByteCodeObj(interp, objPtr); + fflush(stdout); } +#endif /* TCL_COMPILE_DEBUG */ } TclFreeCompileEnv(&compEnv); @@ -784,8 +767,7 @@ SetByteCodeFromAny( if (interp == NULL) { return TCL_ERROR; } - TclSetByteCodeFromAny(interp, objPtr, NULL, NULL); - return TCL_OK; + return TclSetByteCodeFromAny(interp, objPtr, NULL, NULL); } /* @@ -839,10 +821,9 @@ static void FreeByteCodeInternalRep( register Tcl_Obj *objPtr) /* Object whose internal rep to free. */ { - register ByteCode *codePtr = objPtr->internalRep.otherValuePtr; + register ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1; objPtr->typePtr = NULL; - objPtr->internalRep.otherValuePtr = NULL; codePtr->refCount--; if (codePtr->refCount <= 0) { TclCleanupByteCode(codePtr); @@ -862,9 +843,8 @@ FreeByteCodeInternalRep( * None. * * Side effects: - * Frees objPtr's bytecode internal representation and sets its type and - * objPtr->internalRep.otherValuePtr NULL. Also releases its literals and - * frees its auxiliary data items. + * Frees objPtr's bytecode internal representation and sets its type NULL + * Also releases its literals and frees its auxiliary data items. * *---------------------------------------------------------------------- */ @@ -939,7 +919,7 @@ TclCleanupByteCode( * released. */ - if ((codePtr->flags & TCL_BYTECODE_PRECOMPILED) || (interp == NULL)) { + if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { objArrayPtr = codePtr->objArrayPtr; for (i = 0; i < numLitObjects; i++) { @@ -952,17 +932,9 @@ TclCleanupByteCode( codePtr->numLitObjects = 0; } else { objArrayPtr = codePtr->objArrayPtr; - for (i = 0; i < numLitObjects; i++) { - /* - * TclReleaseLiteral sets a ByteCode's object array entry NULL to - * indicate that it has already freed the literal. - */ - - objPtr = *objArrayPtr; - if (objPtr != NULL) { - TclReleaseLiteral(interp, objPtr); - } - objArrayPtr++; + while (numLitObjects--) { + /* TclReleaseLiteral calls Tcl_DecrRefCount() for us */ + TclReleaseLiteral(interp, *objArrayPtr++); } } @@ -987,22 +959,7 @@ TclCleanupByteCode( (char *) codePtr); if (hePtr) { - ExtCmdLoc *eclPtr = Tcl_GetHashValue(hePtr); - - if (eclPtr->type == TCL_LOCATION_SOURCE) { - Tcl_DecrRefCount(eclPtr->path); - } - for (i=0 ; i<eclPtr->nuloc ; i++) { - ckfree(eclPtr->loc[i].line); - } - - if (eclPtr->loc != NULL) { - ckfree(eclPtr->loc); - } - - Tcl_DeleteHashTable(&eclPtr->litInfo); - - ckfree(eclPtr); + ReleaseCmdWordData(Tcl_GetHashValue(hePtr)); Tcl_DeleteHashEntry(hePtr); } } @@ -1139,7 +1096,7 @@ CompileSubstObj( objPtr->typePtr = &substCodeType; TclFreeCompileEnv(&compEnv); - codePtr = objPtr->internalRep.otherValuePtr; + codePtr = objPtr->internalRep.twoPtrValue.ptr1; objPtr->internalRep.ptrAndLongRep.ptr = codePtr; objPtr->internalRep.ptrAndLongRep.value = flags; if (iPtr->varFramePtr->localCachePtr) { @@ -1178,12 +1135,33 @@ FreeSubstCodeInternalRep( register ByteCode *codePtr = objPtr->internalRep.ptrAndLongRep.ptr; objPtr->typePtr = NULL; - objPtr->internalRep.otherValuePtr = NULL; codePtr->refCount--; if (codePtr->refCount <= 0) { TclCleanupByteCode(codePtr); } } + +static void +ReleaseCmdWordData( + ExtCmdLoc *eclPtr) +{ + int i; + + if (eclPtr->type == TCL_LOCATION_SOURCE) { + Tcl_DecrRefCount(eclPtr->path); + } + for (i=0 ; i<eclPtr->nuloc ; i++) { + ckfree((char *) eclPtr->loc[i].line); + } + + if (eclPtr->loc != NULL) { + ckfree((char *) eclPtr->loc); + } + + Tcl_DeleteHashTable (&eclPtr->litInfo); + + ckfree((char *) eclPtr); +} /* *---------------------------------------------------------------------- @@ -1417,6 +1395,32 @@ TclFreeCompileEnv( ckfree(envPtr->localLitTable.buckets); envPtr->localLitTable.buckets = envPtr->localLitTable.staticBuckets; } + if (envPtr->iPtr) { + /* + * We never converted to Bytecode, so free the things we would + * have transferred to it. + */ + + int i; + LiteralEntry *entryPtr = envPtr->literalArrayPtr; + AuxData *auxDataPtr = envPtr->auxDataArrayPtr; + + for (i = 0; i < envPtr->literalArrayNext; i++) { + TclReleaseLiteral((Tcl_Interp *)envPtr->iPtr, entryPtr->objPtr); + entryPtr++; + } + +#ifdef TCL_COMPILE_DEBUG + TclVerifyGlobalLiteralTable(envPtr->iPtr); +#endif /*TCL_COMPILE_DEBUG*/ + + for (i = 0; i < envPtr->auxDataArrayNext; i++) { + if (auxDataPtr->type->freeProc != NULL) { + auxDataPtr->type->freeProc(auxDataPtr->clientData); + } + auxDataPtr++; + } + } if (envPtr->mallocedCodeArray) { ckfree(envPtr->codeStart); } @@ -1433,7 +1437,8 @@ TclFreeCompileEnv( ckfree(envPtr->auxDataArrayPtr); } if (envPtr->extCmdMapPtr) { - ckfree(envPtr->extCmdMapPtr); + ReleaseCmdWordData(envPtr->extCmdMapPtr); + envPtr->extCmdMapPtr = NULL; } /* @@ -1575,6 +1580,10 @@ TclCompileScript( int *wlines, wlineat, cmdLine, *clNext; Tcl_Parse *parsePtr = TclStackAlloc(interp, sizeof(Tcl_Parse)); + if (envPtr->iPtr == NULL) { + Tcl_Panic("TclCompileScript() called on uninitialized CompileEnv"); + } + Tcl_DStringInit(&ds); if (numBytes < 0) { @@ -1887,8 +1896,7 @@ TclCompileScript( tokenPtr[1].start, tokenPtr[1].size); if (cmdPtr != NULL) { TclSetCmdNameObj(interp, - envPtr->literalArrayPtr[objIndex].objPtr, - cmdPtr); + TclFetchLiteral(envPtr, objIndex), cmdPtr); } } else { /* @@ -1905,7 +1913,7 @@ TclCompileScript( if (envPtr->clNext) { TclContinuationsEnterDerived( - envPtr->literalArrayPtr[objIndex].objPtr, + TclFetchLiteral(envPtr, objIndex), tokenPtr[1].start - envPtr->source, eclPtr->loc[wlineat].next[wordIdx]); } @@ -2214,9 +2222,8 @@ TclCompileTokens( Tcl_DStringFree(&textBuffer); if (numCL) { - TclContinuationsEnter( - envPtr->literalArrayPtr[literal].objPtr, numCL, - clPosition); + TclContinuationsEnter(TclFetchLiteral(envPtr, literal), + numCL, clPosition); } numCL = 0; } @@ -2262,7 +2269,7 @@ TclCompileTokens( TclEmitPush(literal, envPtr); numObjsToConcat++; if (numCL) { - TclContinuationsEnter(envPtr->literalArrayPtr[literal].objPtr, + TclContinuationsEnter(TclFetchLiteral(envPtr, literal), numCL, clPosition); } numCL = 0; @@ -2509,6 +2516,10 @@ TclInitByteCodeObj( int i, isNew; Interp *iPtr; + if (envPtr->iPtr == NULL) { + Tcl_Panic("TclInitByteCodeObj() called on uninitialized CompileEnv"); + } + iPtr = envPtr->iPtr; codeBytes = envPtr->codeNext - envPtr->codeStart; @@ -2566,7 +2577,9 @@ TclInitByteCodeObj( p += TCL_ALIGN(codeBytes); /* align object array */ codePtr->objArrayPtr = (Tcl_Obj **) p; for (i = 0; i < numLitObjects; i++) { - if (objPtr == envPtr->literalArrayPtr[i].objPtr) { + Tcl_Obj *fetched = TclFetchLiteral(envPtr, i); + + if (objPtr == fetched) { /* * Prevent circular reference where the bytecode intrep of * a value contains a literal which is that same value. @@ -2585,7 +2598,7 @@ TclInitByteCodeObj( Tcl_IncrRefCount(codePtr->objArrayPtr[i]); Tcl_DecrRefCount(objPtr); } else { - codePtr->objArrayPtr[i] = envPtr->literalArrayPtr[i].objPtr; + codePtr->objArrayPtr[i] = fetched; } } @@ -2634,7 +2647,7 @@ TclInitByteCodeObj( */ TclFreeIntRep(objPtr); - objPtr->internalRep.otherValuePtr = codePtr; + objPtr->internalRep.twoPtrValue.ptr1 = codePtr; objPtr->typePtr = &tclByteCodeType; /* @@ -2646,6 +2659,9 @@ TclInitByteCodeObj( &isNew), envPtr->extCmdMapPtr); envPtr->extCmdMapPtr = NULL; + /* We've used up the CompileEnv. Mark as uninitialized. */ + envPtr->iPtr = NULL; + codePtr->localCachePtr = NULL; } @@ -3558,7 +3574,7 @@ TclGetInstructionTable(void) /* *-------------------------------------------------------------- * - * TclRegisterAuxDataType -- + * RegisterAuxDataType -- * * This procedure is called to register a new AuxData type in the table * of all AuxData types supported by Tcl. @@ -3574,8 +3590,8 @@ TclGetInstructionTable(void) *-------------------------------------------------------------- */ -void -TclRegisterAuxDataType( +static void +RegisterAuxDataType( const AuxDataType *typePtr) /* Information about object type; storage must * be statically allocated (must live forever; * will not be deallocated). */ @@ -3679,9 +3695,9 @@ TclInitAuxDataTypeTable(void) * There are only two AuxData type at this time, so register them here. */ - TclRegisterAuxDataType(&tclForeachInfoType); - TclRegisterAuxDataType(&tclJumptableInfoType); - TclRegisterAuxDataType(&tclDictUpdateInfoType); + RegisterAuxDataType(&tclForeachInfoType); + RegisterAuxDataType(&tclJumptableInfoType); + RegisterAuxDataType(&tclDictUpdateInfoType); } /* @@ -4053,7 +4069,7 @@ Tcl_Obj * TclDisassembleByteCodeObj( Tcl_Obj *objPtr) /* The bytecode object to disassemble. */ { - ByteCode *codePtr = objPtr->internalRep.otherValuePtr; + ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1; unsigned char *codeStart, *codeLimit, *pc; unsigned char *codeDeltaNext, *codeLengthNext; unsigned char *srcDeltaNext, *srcLengthNext; @@ -4558,7 +4574,11 @@ TclGetInnerContext( if (!objPtr) { Tcl_Panic("InnerContext: bad tos -- appending null object"); } - if (objPtr->refCount<=0 || objPtr->refCount==0x61616161) { + if ((objPtr->refCount<=0) +#ifdef TCL_MEM_DEBUG + || (objPtr->refCount==0x61616161) +#endif + ) { Tcl_Panic("InnerContext: bad tos -- appending freed object %p", objPtr); } diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 3302f9b..f5edfaa 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -80,7 +80,7 @@ typedef enum { * to a catch PC offset. */ } ExceptionRangeType; -typedef struct ExceptionRange { +typedef struct { ExceptionRangeType type; /* The kind of ExceptionRange. */ int nestingLevel; /* Static depth of the exception range. Used * to find the most deeply-nested range @@ -107,7 +107,7 @@ typedef struct ExceptionRange { * source offset is not monotonic. */ -typedef struct CmdLocation { +typedef struct { int codeOffset; /* Offset of first byte of command code. */ int numCodeBytes; /* Number of bytes for command's code. */ int srcOffset; /* Offset of first char of the command. */ @@ -125,7 +125,7 @@ typedef struct CmdLocation { * frame and associated information, like the path of a sourced file. */ -typedef struct ECL { +typedef struct { int srcOffset; /* Command location to find the entry. */ int nline; /* Number of words in the command */ int *line; /* Line information for all words in the @@ -135,7 +135,7 @@ typedef struct ECL { * lines. */ } ECL; -typedef struct ExtCmdLoc { +typedef struct { int type; /* Context type. */ int start; /* Starting line for compiled script. Needed * for the extended recompile check in @@ -711,8 +711,10 @@ typedef struct ByteCode { #define INST_ARRAY_MAKE_STK 161 #define INST_ARRAY_MAKE_IMM 162 +#define INST_INVOKE_REPLACE 163 + /* The last opcode */ -#define LAST_INST_OPCODE 162 +#define LAST_INST_OPCODE 163 /* * Table describing the Tcl bytecode instructions: their name (for displaying @@ -952,11 +954,10 @@ MODULE_SCOPE ExceptionRange * TclGetExceptionRangeForPc(unsigned char *pc, MODULE_SCOPE void TclExpandJumpFixupArray(JumpFixupArray *fixupArrayPtr); MODULE_SCOPE int TclNRExecuteByteCode(Tcl_Interp *interp, ByteCode *codePtr); +MODULE_SCOPE Tcl_Obj * TclFetchLiteral(CompileEnv *envPtr, unsigned int index); MODULE_SCOPE void TclFinalizeAuxDataTypeTable(void); MODULE_SCOPE int TclFindCompiledLocal(const char *name, int nameChars, int create, CompileEnv *envPtr); -MODULE_SCOPE LiteralEntry * TclLookupLiteralEntry(Tcl_Interp *interp, - Tcl_Obj *objPtr); MODULE_SCOPE int TclFixupForwardJump(CompileEnv *envPtr, JumpFixup *jumpFixupPtr, int jumpDist, int distThreshold); @@ -965,7 +966,6 @@ MODULE_SCOPE void TclFreeJumpFixupArray(JumpFixupArray *fixupArrayPtr); MODULE_SCOPE void TclInitAuxDataTypeTable(void); MODULE_SCOPE void TclInitByteCodeObj(Tcl_Obj *objPtr, CompileEnv *envPtr); -MODULE_SCOPE void TclInitCompilation(void); MODULE_SCOPE void TclInitCompileEnv(Tcl_Interp *interp, CompileEnv *envPtr, const char *string, int numBytes, const CmdFrame *invoker, int word); @@ -985,7 +985,6 @@ MODULE_SCOPE void TclPrintObject(FILE *outFile, Tcl_Obj *objPtr, int maxChars); MODULE_SCOPE void TclPrintSource(FILE *outFile, const char *string, int maxChars); -MODULE_SCOPE void TclRegisterAuxDataType(const AuxDataType *typePtr); MODULE_SCOPE int TclRegisterLiteral(CompileEnv *envPtr, char *bytes, int length, int flags); MODULE_SCOPE void TclReleaseLiteral(Tcl_Interp *interp, Tcl_Obj *objPtr); diff --git a/generic/tclConfig.c b/generic/tclConfig.c index a4ba71a..ce36047 100644 --- a/generic/tclConfig.c +++ b/generic/tclConfig.c @@ -31,7 +31,7 @@ * and the (Tcl_Interp *) in which it is stored. */ -typedef struct QCCD { +typedef struct { Tcl_Obj *pkg; Tcl_Interp *interp; } QCCD; @@ -223,8 +223,8 @@ QueryConfigObjCmd( Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg?"); return TCL_ERROR; } - if (Tcl_GetIndexFromObj(interp, objv[1], subcmdStrings, "subcommand", 0, - &index) != TCL_OK) { + if (Tcl_GetIndexFromObjStruct(interp, objv[1], subcmdStrings, + sizeof(char *), "subcommand", 0, &index) != TCL_OK) { return TCL_ERROR; } diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 6d6a03c..cc3ce06 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -94,9 +94,7 @@ TCLAPI void Tcl_DbIncrRefCount(Tcl_Obj *objPtr, const char *file, /* 21 */ TCLAPI int Tcl_DbIsShared(Tcl_Obj *objPtr, const char *file, int line); -/* 22 */ -TCLAPI Tcl_Obj * Tcl_DbNewBooleanObj(int boolValue, const char *file, - int line); +/* Slot 22 is reserved */ /* 23 */ TCLAPI Tcl_Obj * Tcl_DbNewByteArrayObj(const unsigned char *bytes, int length, const char *file, int line); @@ -133,10 +131,7 @@ TCLAPI int Tcl_GetDouble(Tcl_Interp *interp, const char *src, /* 35 */ TCLAPI int Tcl_GetDoubleFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, double *doublePtr); -/* 36 */ -TCLAPI int Tcl_GetIndexFromObj(Tcl_Interp *interp, - Tcl_Obj *objPtr, const char *const *tablePtr, - const char *msg, int flags, int *indexPtr); +/* Slot 36 is reserved */ /* 37 */ TCLAPI int Tcl_GetInt(Tcl_Interp *interp, const char *src, int *intPtr); @@ -173,15 +168,13 @@ TCLAPI int Tcl_ListObjLength(Tcl_Interp *interp, TCLAPI int Tcl_ListObjReplace(Tcl_Interp *interp, Tcl_Obj *listPtr, int first, int count, int objc, Tcl_Obj *const objv[]); -/* 49 */ -TCLAPI Tcl_Obj * Tcl_NewBooleanObj(int boolValue); +/* Slot 49 is reserved */ /* 50 */ TCLAPI Tcl_Obj * Tcl_NewByteArrayObj(const unsigned char *bytes, int length); /* 51 */ TCLAPI Tcl_Obj * Tcl_NewDoubleObj(double doubleValue); -/* 52 */ -TCLAPI Tcl_Obj * Tcl_NewIntObj(int intValue); +/* Slot 52 is reserved */ /* 53 */ TCLAPI Tcl_Obj * Tcl_NewListObj(int objc, Tcl_Obj *const objv[]); /* 54 */ @@ -190,8 +183,7 @@ TCLAPI Tcl_Obj * Tcl_NewLongObj(long longValue); TCLAPI Tcl_Obj * Tcl_NewObj(void); /* 56 */ TCLAPI Tcl_Obj * Tcl_NewStringObj(const char *bytes, int length); -/* 57 */ -TCLAPI void Tcl_SetBooleanObj(Tcl_Obj *objPtr, int boolValue); +/* Slot 57 is reserved */ /* 58 */ TCLAPI unsigned char * Tcl_SetByteArrayLength(Tcl_Obj *objPtr, int length); /* 59 */ @@ -199,8 +191,7 @@ TCLAPI void Tcl_SetByteArrayObj(Tcl_Obj *objPtr, const unsigned char *bytes, int length); /* 60 */ TCLAPI void Tcl_SetDoubleObj(Tcl_Obj *objPtr, double doubleValue); -/* 61 */ -TCLAPI void Tcl_SetIntObj(Tcl_Obj *objPtr, int intValue); +/* Slot 61 is reserved */ /* 62 */ TCLAPI void Tcl_SetListObj(Tcl_Obj *objPtr, int objc, Tcl_Obj *const objv[]); @@ -211,12 +202,8 @@ TCLAPI void Tcl_SetObjLength(Tcl_Obj *objPtr, int length); /* 65 */ TCLAPI void Tcl_SetStringObj(Tcl_Obj *objPtr, const char *bytes, int length); -/* 66 */ -TCLAPI void Tcl_AddErrorInfo(Tcl_Interp *interp, - const char *message); -/* 67 */ -TCLAPI void Tcl_AddObjErrorInfo(Tcl_Interp *interp, - const char *message, int length); +/* Slot 66 is reserved */ +/* Slot 67 is reserved */ /* 68 */ TCLAPI void Tcl_AllowExceptions(Tcl_Interp *interp); /* 69 */ @@ -385,11 +372,9 @@ TCLAPI int Tcl_Eof(Tcl_Channel chan); TCLAPI const char * Tcl_ErrnoId(void); /* 128 */ TCLAPI const char * Tcl_ErrnoMsg(int err); -/* 129 */ -TCLAPI int Tcl_Eval(Tcl_Interp *interp, const char *script); +/* Slot 129 is reserved */ /* Slot 130 is reserved */ -/* 131 */ -TCLAPI int Tcl_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr); +/* Slot 131 is reserved */ /* 132 */ TCLAPI void Tcl_EventuallyFree(ClientData clientData, Tcl_FreeProc *freeProc); @@ -514,9 +499,7 @@ TCLAPI Tcl_Interp * Tcl_GetSlave(Tcl_Interp *interp, TCLAPI Tcl_Channel Tcl_GetStdChannel(int type); /* 174 */ TCLAPI const char * Tcl_GetStringResult(Tcl_Interp *interp); -/* 175 */ -TCLAPI const char * Tcl_GetVar(Tcl_Interp *interp, const char *varName, - int flags); +/* Slot 175 is reserved */ /* 176 */ TCLAPI const char * Tcl_GetVar2(Tcl_Interp *interp, const char *part1, const char *part2, int flags); @@ -671,9 +654,7 @@ TCLAPI void Tcl_SetObjResult(Tcl_Interp *interp, Tcl_Obj *resultObjPtr); /* 236 */ TCLAPI void Tcl_SetStdChannel(Tcl_Channel channel, int type); -/* 237 */ -TCLAPI const char * Tcl_SetVar(Tcl_Interp *interp, const char *varName, - const char *newValue, int flags); +/* Slot 237 is reserved */ /* 238 */ TCLAPI const char * Tcl_SetVar2(Tcl_Interp *interp, const char *part1, const char *part2, const char *newValue, @@ -699,10 +680,7 @@ TCLAPI void Tcl_StaticPackage(Tcl_Interp *interp, /* 245 */ TCLAPI int Tcl_StringMatch(const char *str, const char *pattern); /* Slot 246 is reserved */ -/* 247 */ -TCLAPI int Tcl_TraceVar(Tcl_Interp *interp, const char *varName, - int flags, Tcl_VarTraceProc *proc, - ClientData clientData); +/* Slot 247 is reserved */ /* 248 */ TCLAPI int Tcl_TraceVar2(Tcl_Interp *interp, const char *part1, const char *part2, int flags, @@ -720,17 +698,11 @@ TCLAPI void Tcl_UnlinkVar(Tcl_Interp *interp, /* 252 */ TCLAPI int Tcl_UnregisterChannel(Tcl_Interp *interp, Tcl_Channel chan); -/* 253 */ -TCLAPI int Tcl_UnsetVar(Tcl_Interp *interp, const char *varName, - int flags); +/* Slot 253 is reserved */ /* 254 */ TCLAPI int Tcl_UnsetVar2(Tcl_Interp *interp, const char *part1, const char *part2, int flags); -/* 255 */ -TCLAPI void Tcl_UntraceVar(Tcl_Interp *interp, - const char *varName, int flags, - Tcl_VarTraceProc *proc, - ClientData clientData); +/* Slot 255 is reserved */ /* 256 */ TCLAPI void Tcl_UntraceVar2(Tcl_Interp *interp, const char *part1, const char *part2, @@ -739,20 +711,13 @@ TCLAPI void Tcl_UntraceVar2(Tcl_Interp *interp, /* 257 */ TCLAPI void Tcl_UpdateLinkedVar(Tcl_Interp *interp, const char *varName); -/* 258 */ -TCLAPI int Tcl_UpVar(Tcl_Interp *interp, const char *frameName, - const char *varName, const char *localName, - int flags); +/* Slot 258 is reserved */ /* 259 */ TCLAPI int Tcl_UpVar2(Tcl_Interp *interp, const char *frameName, const char *part1, const char *part2, const char *localName, int flags); /* Slot 260 is reserved */ -/* 261 */ -TCLAPI ClientData Tcl_VarTraceInfo(Tcl_Interp *interp, - const char *varName, int flags, - Tcl_VarTraceProc *procPtr, - ClientData prevClientData); +/* Slot 261 is reserved */ /* 262 */ TCLAPI ClientData Tcl_VarTraceInfo2(Tcl_Interp *interp, const char *part1, const char *part2, @@ -774,9 +739,7 @@ TCLAPI char * Tcl_HashStats(Tcl_HashTable *tablePtr); /* 270 */ TCLAPI const char * Tcl_ParseVar(Tcl_Interp *interp, const char *start, const char **termPtr); -/* 271 */ -TCLAPI const char * Tcl_PkgPresent(Tcl_Interp *interp, const char *name, - const char *version, int exact); +/* Slot 271 is reserved */ /* 272 */ TCLAPI const char * Tcl_PkgPresentEx(Tcl_Interp *interp, const char *name, const char *version, @@ -784,9 +747,7 @@ TCLAPI const char * Tcl_PkgPresentEx(Tcl_Interp *interp, /* 273 */ TCLAPI int TclPkgProvide(Tcl_Interp *interp, const char *name, const char *version); -/* 274 */ -TCLAPI const char * Tcl_PkgRequire(Tcl_Interp *interp, const char *name, - const char *version, int exact); +/* Slot 274 is reserved */ /* Slot 275 is reserved */ /* Slot 276 is reserved */ /* 277 */ @@ -821,8 +782,7 @@ TCLAPI void Tcl_CreateThreadExitHandler(Tcl_ExitProc *proc, /* 289 */ TCLAPI void Tcl_DeleteThreadExitHandler(Tcl_ExitProc *proc, ClientData clientData); -/* 290 */ -TCLAPI void Tcl_DiscardResult(Tcl_SavedResult *statePtr); +/* Slot 290 is reserved */ /* 291 */ TCLAPI int Tcl_EvalEx(Tcl_Interp *interp, const char *script, int numBytes, int flags); @@ -886,12 +846,8 @@ TCLAPI int Tcl_NumUtfChars(const char *src, int length); /* 313 */ TCLAPI int Tcl_ReadChars(Tcl_Channel channel, Tcl_Obj *objPtr, int charsToRead, int appendFlag); -/* 314 */ -TCLAPI void Tcl_RestoreResult(Tcl_Interp *interp, - Tcl_SavedResult *statePtr); -/* 315 */ -TCLAPI void Tcl_SaveResult(Tcl_Interp *interp, - Tcl_SavedResult *statePtr); +/* Slot 314 is reserved */ +/* Slot 315 is reserved */ /* 316 */ TCLAPI int Tcl_SetSystemEncoding(Tcl_Interp *interp, const char *name); @@ -1808,7 +1764,7 @@ typedef struct TclStubs { void (*tcl_DbDecrRefCount) (Tcl_Obj *objPtr, const char *file, int line); /* 19 */ void (*tcl_DbIncrRefCount) (Tcl_Obj *objPtr, const char *file, int line); /* 20 */ int (*tcl_DbIsShared) (Tcl_Obj *objPtr, const char *file, int line); /* 21 */ - Tcl_Obj * (*tcl_DbNewBooleanObj) (int boolValue, const char *file, int line); /* 22 */ + void (*reserved22)(void); Tcl_Obj * (*tcl_DbNewByteArrayObj) (const unsigned char *bytes, int length, const char *file, int line); /* 23 */ Tcl_Obj * (*tcl_DbNewDoubleObj) (double doubleValue, const char *file, int line); /* 24 */ Tcl_Obj * (*tcl_DbNewListObj) (int objc, Tcl_Obj *const *objv, const char *file, int line); /* 25 */ @@ -1822,7 +1778,7 @@ typedef struct TclStubs { unsigned char * (*tcl_GetByteArrayFromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 33 */ int (*tcl_GetDouble) (Tcl_Interp *interp, const char *src, double *doublePtr); /* 34 */ int (*tcl_GetDoubleFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, double *doublePtr); /* 35 */ - int (*tcl_GetIndexFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, const char *const *tablePtr, const char *msg, int flags, int *indexPtr); /* 36 */ + void (*reserved36)(void); int (*tcl_GetInt) (Tcl_Interp *interp, const char *src, int *intPtr); /* 37 */ int (*tcl_GetIntFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *intPtr); /* 38 */ int (*tcl_GetLongFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, long *longPtr); /* 39 */ @@ -1835,25 +1791,25 @@ typedef struct TclStubs { int (*tcl_ListObjIndex) (Tcl_Interp *interp, Tcl_Obj *listPtr, int index, Tcl_Obj **objPtrPtr); /* 46 */ int (*tcl_ListObjLength) (Tcl_Interp *interp, Tcl_Obj *listPtr, int *lengthPtr); /* 47 */ int (*tcl_ListObjReplace) (Tcl_Interp *interp, Tcl_Obj *listPtr, int first, int count, int objc, Tcl_Obj *const objv[]); /* 48 */ - Tcl_Obj * (*tcl_NewBooleanObj) (int boolValue); /* 49 */ + void (*reserved49)(void); Tcl_Obj * (*tcl_NewByteArrayObj) (const unsigned char *bytes, int length); /* 50 */ Tcl_Obj * (*tcl_NewDoubleObj) (double doubleValue); /* 51 */ - Tcl_Obj * (*tcl_NewIntObj) (int intValue); /* 52 */ + void (*reserved52)(void); Tcl_Obj * (*tcl_NewListObj) (int objc, Tcl_Obj *const objv[]); /* 53 */ Tcl_Obj * (*tcl_NewLongObj) (long longValue); /* 54 */ Tcl_Obj * (*tcl_NewObj) (void); /* 55 */ Tcl_Obj * (*tcl_NewStringObj) (const char *bytes, int length); /* 56 */ - void (*tcl_SetBooleanObj) (Tcl_Obj *objPtr, int boolValue); /* 57 */ + void (*reserved57)(void); unsigned char * (*tcl_SetByteArrayLength) (Tcl_Obj *objPtr, int length); /* 58 */ void (*tcl_SetByteArrayObj) (Tcl_Obj *objPtr, const unsigned char *bytes, int length); /* 59 */ void (*tcl_SetDoubleObj) (Tcl_Obj *objPtr, double doubleValue); /* 60 */ - void (*tcl_SetIntObj) (Tcl_Obj *objPtr, int intValue); /* 61 */ + void (*reserved61)(void); void (*tcl_SetListObj) (Tcl_Obj *objPtr, int objc, Tcl_Obj *const objv[]); /* 62 */ void (*tcl_SetLongObj) (Tcl_Obj *objPtr, long longValue); /* 63 */ void (*tcl_SetObjLength) (Tcl_Obj *objPtr, int length); /* 64 */ void (*tcl_SetStringObj) (Tcl_Obj *objPtr, const char *bytes, int length); /* 65 */ - void (*tcl_AddErrorInfo) (Tcl_Interp *interp, const char *message); /* 66 */ - void (*tcl_AddObjErrorInfo) (Tcl_Interp *interp, const char *message, int length); /* 67 */ + void (*reserved66)(void); + void (*reserved67)(void); void (*tcl_AllowExceptions) (Tcl_Interp *interp); /* 68 */ void (*tcl_AppendElement) (Tcl_Interp *interp, const char *element); /* 69 */ void (*tcl_AppendResult) (Tcl_Interp *interp, ...); /* 70 */ @@ -1915,9 +1871,9 @@ typedef struct TclStubs { int (*tcl_Eof) (Tcl_Channel chan); /* 126 */ const char * (*tcl_ErrnoId) (void); /* 127 */ const char * (*tcl_ErrnoMsg) (int err); /* 128 */ - int (*tcl_Eval) (Tcl_Interp *interp, const char *script); /* 129 */ + void (*reserved129)(void); void (*reserved130)(void); - int (*tcl_EvalObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 131 */ + void (*reserved131)(void); void (*tcl_EventuallyFree) (ClientData clientData, Tcl_FreeProc *freeProc); /* 132 */ void (*tcl_Exit) (int status); /* 133 */ int (*tcl_ExposeCommand) (Tcl_Interp *interp, const char *hiddenCmdToken, const char *cmdName); /* 134 */ @@ -1969,7 +1925,7 @@ typedef struct TclStubs { Tcl_Interp * (*tcl_GetSlave) (Tcl_Interp *interp, const char *slaveName); /* 172 */ Tcl_Channel (*tcl_GetStdChannel) (int type); /* 173 */ const char * (*tcl_GetStringResult) (Tcl_Interp *interp); /* 174 */ - const char * (*tcl_GetVar) (Tcl_Interp *interp, const char *varName, int flags); /* 175 */ + void (*reserved175)(void); const char * (*tcl_GetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags); /* 176 */ void (*reserved177)(void); void (*reserved178)(void); @@ -2031,7 +1987,7 @@ typedef struct TclStubs { void (*tcl_SetObjErrorCode) (Tcl_Interp *interp, Tcl_Obj *errorObjPtr); /* 234 */ void (*tcl_SetObjResult) (Tcl_Interp *interp, Tcl_Obj *resultObjPtr); /* 235 */ void (*tcl_SetStdChannel) (Tcl_Channel channel, int type); /* 236 */ - const char * (*tcl_SetVar) (Tcl_Interp *interp, const char *varName, const char *newValue, int flags); /* 237 */ + void (*reserved237)(void); const char * (*tcl_SetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, const char *newValue, int flags); /* 238 */ const char * (*tcl_SignalId) (int sig); /* 239 */ const char * (*tcl_SignalMsg) (int sig); /* 240 */ @@ -2041,21 +1997,21 @@ typedef struct TclStubs { void (*tcl_StaticPackage) (Tcl_Interp *interp, const char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* 244 */ int (*tcl_StringMatch) (const char *str, const char *pattern); /* 245 */ void (*reserved246)(void); - int (*tcl_TraceVar) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 247 */ + void (*reserved247)(void); int (*tcl_TraceVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 248 */ char * (*tcl_TranslateFileName) (Tcl_Interp *interp, const char *name, Tcl_DString *bufferPtr); /* 249 */ int (*tcl_Ungets) (Tcl_Channel chan, const char *str, int len, int atHead); /* 250 */ void (*tcl_UnlinkVar) (Tcl_Interp *interp, const char *varName); /* 251 */ int (*tcl_UnregisterChannel) (Tcl_Interp *interp, Tcl_Channel chan); /* 252 */ - int (*tcl_UnsetVar) (Tcl_Interp *interp, const char *varName, int flags); /* 253 */ + void (*reserved253)(void); int (*tcl_UnsetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags); /* 254 */ - void (*tcl_UntraceVar) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 255 */ + void (*reserved255)(void); void (*tcl_UntraceVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 256 */ void (*tcl_UpdateLinkedVar) (Tcl_Interp *interp, const char *varName); /* 257 */ - int (*tcl_UpVar) (Tcl_Interp *interp, const char *frameName, const char *varName, const char *localName, int flags); /* 258 */ + void (*reserved258)(void); int (*tcl_UpVar2) (Tcl_Interp *interp, const char *frameName, const char *part1, const char *part2, const char *localName, int flags); /* 259 */ void (*reserved260)(void); - ClientData (*tcl_VarTraceInfo) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData); /* 261 */ + void (*reserved261)(void); ClientData (*tcl_VarTraceInfo2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData); /* 262 */ int (*tcl_Write) (Tcl_Channel chan, const char *s, int slen); /* 263 */ void (*tcl_WrongNumArgs) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], const char *message); /* 264 */ @@ -2065,10 +2021,10 @@ typedef struct TclStubs { void (*reserved268)(void); char * (*tcl_HashStats) (Tcl_HashTable *tablePtr); /* 269 */ const char * (*tcl_ParseVar) (Tcl_Interp *interp, const char *start, const char **termPtr); /* 270 */ - const char * (*tcl_PkgPresent) (Tcl_Interp *interp, const char *name, const char *version, int exact); /* 271 */ + void (*reserved271)(void); const char * (*tcl_PkgPresentEx) (Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 272 */ int (*tclPkgProvide) (Tcl_Interp *interp, const char *name, const char *version); /* 273 */ - const char * (*tcl_PkgRequire) (Tcl_Interp *interp, const char *name, const char *version, int exact); /* 274 */ + void (*reserved274)(void); void (*reserved275)(void); void (*reserved276)(void); Tcl_Pid (*tcl_WaitPid) (Tcl_Pid pid, int *statPtr, int options); /* 277 */ @@ -2084,7 +2040,7 @@ typedef struct TclStubs { Tcl_Encoding (*tcl_CreateEncoding) (const Tcl_EncodingType *typePtr); /* 287 */ void (*tcl_CreateThreadExitHandler) (Tcl_ExitProc *proc, ClientData clientData); /* 288 */ void (*tcl_DeleteThreadExitHandler) (Tcl_ExitProc *proc, ClientData clientData); /* 289 */ - void (*tcl_DiscardResult) (Tcl_SavedResult *statePtr); /* 290 */ + void (*reserved290)(void); int (*tcl_EvalEx) (Tcl_Interp *interp, const char *script, int numBytes, int flags); /* 291 */ int (*tcl_EvalObjv) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags); /* 292 */ int (*tcl_EvalObjEx) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 293 */ @@ -2108,8 +2064,8 @@ typedef struct TclStubs { void (*tcl_ConditionWait) (Tcl_Condition *condPtr, Tcl_Mutex *mutexPtr, const Tcl_Time *timePtr); /* 311 */ int (*tcl_NumUtfChars) (const char *src, int length); /* 312 */ int (*tcl_ReadChars) (Tcl_Channel channel, Tcl_Obj *objPtr, int charsToRead, int appendFlag); /* 313 */ - void (*tcl_RestoreResult) (Tcl_Interp *interp, Tcl_SavedResult *statePtr); /* 314 */ - void (*tcl_SaveResult) (Tcl_Interp *interp, Tcl_SavedResult *statePtr); /* 315 */ + void (*reserved314)(void); + void (*reserved315)(void); int (*tcl_SetSystemEncoding) (Tcl_Interp *interp, const char *name); /* 316 */ Tcl_Obj * (*tcl_SetVar2Ex) (Tcl_Interp *interp, const char *part1, const char *part2, Tcl_Obj *newValuePtr, int flags); /* 317 */ void (*tcl_ThreadAlert) (Tcl_ThreadId threadId); /* 318 */ @@ -2497,8 +2453,7 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_DbIncrRefCount) /* 20 */ #define Tcl_DbIsShared \ (tclStubsPtr->tcl_DbIsShared) /* 21 */ -#define Tcl_DbNewBooleanObj \ - (tclStubsPtr->tcl_DbNewBooleanObj) /* 22 */ +/* Slot 22 is reserved */ #define Tcl_DbNewByteArrayObj \ (tclStubsPtr->tcl_DbNewByteArrayObj) /* 23 */ #define Tcl_DbNewDoubleObj \ @@ -2525,8 +2480,7 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_GetDouble) /* 34 */ #define Tcl_GetDoubleFromObj \ (tclStubsPtr->tcl_GetDoubleFromObj) /* 35 */ -#define Tcl_GetIndexFromObj \ - (tclStubsPtr->tcl_GetIndexFromObj) /* 36 */ +/* Slot 36 is reserved */ #define Tcl_GetInt \ (tclStubsPtr->tcl_GetInt) /* 37 */ #define Tcl_GetIntFromObj \ @@ -2551,14 +2505,12 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_ListObjLength) /* 47 */ #define Tcl_ListObjReplace \ (tclStubsPtr->tcl_ListObjReplace) /* 48 */ -#define Tcl_NewBooleanObj \ - (tclStubsPtr->tcl_NewBooleanObj) /* 49 */ +/* Slot 49 is reserved */ #define Tcl_NewByteArrayObj \ (tclStubsPtr->tcl_NewByteArrayObj) /* 50 */ #define Tcl_NewDoubleObj \ (tclStubsPtr->tcl_NewDoubleObj) /* 51 */ -#define Tcl_NewIntObj \ - (tclStubsPtr->tcl_NewIntObj) /* 52 */ +/* Slot 52 is reserved */ #define Tcl_NewListObj \ (tclStubsPtr->tcl_NewListObj) /* 53 */ #define Tcl_NewLongObj \ @@ -2567,16 +2519,14 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_NewObj) /* 55 */ #define Tcl_NewStringObj \ (tclStubsPtr->tcl_NewStringObj) /* 56 */ -#define Tcl_SetBooleanObj \ - (tclStubsPtr->tcl_SetBooleanObj) /* 57 */ +/* Slot 57 is reserved */ #define Tcl_SetByteArrayLength \ (tclStubsPtr->tcl_SetByteArrayLength) /* 58 */ #define Tcl_SetByteArrayObj \ (tclStubsPtr->tcl_SetByteArrayObj) /* 59 */ #define Tcl_SetDoubleObj \ (tclStubsPtr->tcl_SetDoubleObj) /* 60 */ -#define Tcl_SetIntObj \ - (tclStubsPtr->tcl_SetIntObj) /* 61 */ +/* Slot 61 is reserved */ #define Tcl_SetListObj \ (tclStubsPtr->tcl_SetListObj) /* 62 */ #define Tcl_SetLongObj \ @@ -2585,10 +2535,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_SetObjLength) /* 64 */ #define Tcl_SetStringObj \ (tclStubsPtr->tcl_SetStringObj) /* 65 */ -#define Tcl_AddErrorInfo \ - (tclStubsPtr->tcl_AddErrorInfo) /* 66 */ -#define Tcl_AddObjErrorInfo \ - (tclStubsPtr->tcl_AddObjErrorInfo) /* 67 */ +/* Slot 66 is reserved */ +/* Slot 67 is reserved */ #define Tcl_AllowExceptions \ (tclStubsPtr->tcl_AllowExceptions) /* 68 */ #define Tcl_AppendElement \ @@ -2709,11 +2657,9 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_ErrnoId) /* 127 */ #define Tcl_ErrnoMsg \ (tclStubsPtr->tcl_ErrnoMsg) /* 128 */ -#define Tcl_Eval \ - (tclStubsPtr->tcl_Eval) /* 129 */ +/* Slot 129 is reserved */ /* Slot 130 is reserved */ -#define Tcl_EvalObj \ - (tclStubsPtr->tcl_EvalObj) /* 131 */ +/* Slot 131 is reserved */ #define Tcl_EventuallyFree \ (tclStubsPtr->tcl_EventuallyFree) /* 132 */ #define Tcl_Exit \ @@ -2805,8 +2751,7 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_GetStdChannel) /* 173 */ #define Tcl_GetStringResult \ (tclStubsPtr->tcl_GetStringResult) /* 174 */ -#define Tcl_GetVar \ - (tclStubsPtr->tcl_GetVar) /* 175 */ +/* Slot 175 is reserved */ #define Tcl_GetVar2 \ (tclStubsPtr->tcl_GetVar2) /* 176 */ /* Slot 177 is reserved */ @@ -2925,8 +2870,7 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_SetObjResult) /* 235 */ #define Tcl_SetStdChannel \ (tclStubsPtr->tcl_SetStdChannel) /* 236 */ -#define Tcl_SetVar \ - (tclStubsPtr->tcl_SetVar) /* 237 */ +/* Slot 237 is reserved */ #define Tcl_SetVar2 \ (tclStubsPtr->tcl_SetVar2) /* 238 */ #define Tcl_SignalId \ @@ -2944,8 +2888,7 @@ extern const TclStubs *tclStubsPtr; #define Tcl_StringMatch \ (tclStubsPtr->tcl_StringMatch) /* 245 */ /* Slot 246 is reserved */ -#define Tcl_TraceVar \ - (tclStubsPtr->tcl_TraceVar) /* 247 */ +/* Slot 247 is reserved */ #define Tcl_TraceVar2 \ (tclStubsPtr->tcl_TraceVar2) /* 248 */ #define Tcl_TranslateFileName \ @@ -2956,23 +2899,19 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_UnlinkVar) /* 251 */ #define Tcl_UnregisterChannel \ (tclStubsPtr->tcl_UnregisterChannel) /* 252 */ -#define Tcl_UnsetVar \ - (tclStubsPtr->tcl_UnsetVar) /* 253 */ +/* Slot 253 is reserved */ #define Tcl_UnsetVar2 \ (tclStubsPtr->tcl_UnsetVar2) /* 254 */ -#define Tcl_UntraceVar \ - (tclStubsPtr->tcl_UntraceVar) /* 255 */ +/* Slot 255 is reserved */ #define Tcl_UntraceVar2 \ (tclStubsPtr->tcl_UntraceVar2) /* 256 */ #define Tcl_UpdateLinkedVar \ (tclStubsPtr->tcl_UpdateLinkedVar) /* 257 */ -#define Tcl_UpVar \ - (tclStubsPtr->tcl_UpVar) /* 258 */ +/* Slot 258 is reserved */ #define Tcl_UpVar2 \ (tclStubsPtr->tcl_UpVar2) /* 259 */ /* Slot 260 is reserved */ -#define Tcl_VarTraceInfo \ - (tclStubsPtr->tcl_VarTraceInfo) /* 261 */ +/* Slot 261 is reserved */ #define Tcl_VarTraceInfo2 \ (tclStubsPtr->tcl_VarTraceInfo2) /* 262 */ #define Tcl_Write \ @@ -2989,14 +2928,12 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_HashStats) /* 269 */ #define Tcl_ParseVar \ (tclStubsPtr->tcl_ParseVar) /* 270 */ -#define Tcl_PkgPresent \ - (tclStubsPtr->tcl_PkgPresent) /* 271 */ +/* Slot 271 is reserved */ #define Tcl_PkgPresentEx \ (tclStubsPtr->tcl_PkgPresentEx) /* 272 */ #define TclPkgProvide \ (tclStubsPtr->tclPkgProvide) /* 273 */ -#define Tcl_PkgRequire \ - (tclStubsPtr->tcl_PkgRequire) /* 274 */ +/* Slot 274 is reserved */ /* Slot 275 is reserved */ /* Slot 276 is reserved */ #define Tcl_WaitPid \ @@ -3023,8 +2960,7 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_CreateThreadExitHandler) /* 288 */ #define Tcl_DeleteThreadExitHandler \ (tclStubsPtr->tcl_DeleteThreadExitHandler) /* 289 */ -#define Tcl_DiscardResult \ - (tclStubsPtr->tcl_DiscardResult) /* 290 */ +/* Slot 290 is reserved */ #define Tcl_EvalEx \ (tclStubsPtr->tcl_EvalEx) /* 291 */ #define Tcl_EvalObjv \ @@ -3071,10 +3007,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_NumUtfChars) /* 312 */ #define Tcl_ReadChars \ (tclStubsPtr->tcl_ReadChars) /* 313 */ -#define Tcl_RestoreResult \ - (tclStubsPtr->tcl_RestoreResult) /* 314 */ -#define Tcl_SaveResult \ - (tclStubsPtr->tcl_SaveResult) /* 315 */ +/* Slot 314 is reserved */ +/* Slot 315 is reserved */ #define Tcl_SetSystemEncoding \ (tclStubsPtr->tcl_SetSystemEncoding) /* 316 */ #define Tcl_SetVar2Ex \ @@ -3711,15 +3645,15 @@ extern const TclStubs *tclStubsPtr; # undef Tcl_GetStringResult # undef Tcl_Init # undef Tcl_SetPanicProc -# undef Tcl_SetVar2 +# undef Tcl_ObjSetVar2 # undef Tcl_StaticPackage # undef TclFSGetNativePath # define Tcl_CreateInterp() (tclStubsPtr->tcl_CreateInterp()) # define Tcl_GetStringResult(interp) (tclStubsPtr->tcl_GetStringResult(interp)) # define Tcl_Init(interp) (tclStubsPtr->tcl_Init(interp)) # define Tcl_SetPanicProc(proc) (tclStubsPtr->tcl_SetPanicProc(proc)) -# define Tcl_SetVar2(interp, part1, part2, newValue, flags) \ - (tclStubsPtr->tcl_SetVar2(interp, part1, part2, newValue, flags)) +# define Tcl_ObjSetVar2(interp, part1, part2, newValue, flags) \ + (tclStubsPtr->tcl_ObjSetVar2(interp, part1, part2, newValue, flags)) #endif #if defined(_WIN32) && defined(UNICODE) @@ -3729,7 +3663,69 @@ TCLAPI void Tcl_MainExW(int argc, wchar_t **argv, Tcl_AppInitProc *appInitProc, Tcl_Interp *interp); #endif +#define Tcl_PkgPresent(interp, name, version, exact) \ + Tcl_PkgPresentEx(interp, name, version, exact, NULL) #define Tcl_PkgProvide(interp, name, version) \ Tcl_PkgProvideEx(interp, name, version, NULL) +#define Tcl_PkgRequire(interp, name, version, exact) \ + Tcl_PkgRequireEx(interp, name, version, exact, NULL) +#define Tcl_Eval(interp,objPtr) \ + Tcl_EvalEx((interp),(objPtr),-1,0) +#define Tcl_GlobalEval(interp,objPtr) \ + Tcl_EvalEx((interp),(objPtr),-1,TCL_EVAL_GLOBAL) +#define Tcl_GetIndexFromObj(interp, objPtr, tablePtr, msg, flags, indexPtr) \ + Tcl_GetIndexFromObjStruct((interp), (objPtr), (tablePtr), \ + sizeof(char *), (msg), (flags), (indexPtr)) +#define Tcl_NewIntObj Tcl_NewLongObj +#define Tcl_SetIntObj Tcl_SetLongObj +#define Tcl_NewBooleanObj(boolValue) \ + Tcl_NewLongObj((boolValue)!=0) +#define Tcl_DbNewBooleanObj(boolValue, file, line) \ + Tcl_DbNewLongObj((boolValue)!=0, file, line) +#define Tcl_SetBooleanObj(objPtr, boolValue) \ + Tcl_SetLongObj((objPtr), (boolValue)!=0) +#define Tcl_AddErrorInfo(interp, message) \ + Tcl_AppendObjToErrorInfo((interp), Tcl_NewStringObj((message), -1)) +#define Tcl_AddObjErrorInfo(interp, message, length) \ + Tcl_AppendObjToErrorInfo((interp), Tcl_NewStringObj((message), length)) +#define Tcl_SaveResult(interp, statePtr) \ + do { \ + *(statePtr) = Tcl_GetObjResult(interp); \ + Tcl_IncrRefCount(*(statePtr)); \ + Tcl_SetObjResult((interp), Tcl_NewObj()); \ + } while(0) +#define Tcl_RestoreResult(interp, statePtr) \ + do { \ + Tcl_ResetResult(interp); \ + Tcl_SetObjResult((interp), *(statePtr)); \ + Tcl_DecrRefCount(*(statePtr)); \ + } while(0) +#define Tcl_DiscardResult(statePtr) \ + Tcl_DecrRefCount(*(statePtr)) +#define Tcl_SetVar(interp, varName, newValue, flags) \ + Tcl_SetVar2(interp, varName, NULL, newValue, flags) +#define Tcl_UnsetVar(interp, varName, flags) \ + Tcl_UnsetVar2(interp, varName, NULL, flags) +#define Tcl_GetVar(interp, varName, flags) \ + Tcl_GetVar2(interp, varName, NULL, flags) +#define Tcl_TraceVar(interp, varName, flags, proc, clientData) \ + Tcl_TraceVar2(interp, varName, NULL, flags, proc, clientData) +#define Tcl_UntraceVar(interp, varName, flags, proc, clientData) \ + Tcl_UntraceVar2(interp, varName, NULL, flags, proc, clientData) +#define Tcl_VarTraceInfo(interp, varName, flags, proc, prevClientData) \ + Tcl_VarTraceInfo2(interp, varName, NULL, flags, proc, prevClientData) +#define Tcl_UpVar(interp, frameName, varName, localName, flags) \ + Tcl_UpVar2(interp, frameName, varName, NULL, localName, flags) + +/* + * Deprecated Tcl procedures: + */ + +#ifndef TCL_NO_DEPRECATED +# define Tcl_EvalObj(interp,objPtr) \ + Tcl_EvalObjEx((interp),(objPtr),0) +# define Tcl_GlobalEvalObj(interp,objPtr) \ + Tcl_EvalObjEx((interp),(objPtr),TCL_EVAL_GLOBAL) +#endif /* !TCL_NO_DEPRECATED */ #endif /* _TCLDECLS */ diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index eb3625e..ad24017 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} }; @@ -361,7 +361,7 @@ DupDictInternalRep( Tcl_Obj *srcPtr, Tcl_Obj *copyPtr) { - Dict *oldDict = srcPtr->internalRep.otherValuePtr; + Dict *oldDict = srcPtr->internalRep.twoPtrValue.ptr1; Dict *newDict = ckalloc(sizeof(Dict)); ChainEntry *cPtr; @@ -396,7 +396,7 @@ DupDictInternalRep( * Store in the object. */ - copyPtr->internalRep.otherValuePtr = newDict; + copyPtr->internalRep.twoPtrValue.ptr1 = newDict; copyPtr->typePtr = &tclDictType; } @@ -422,14 +422,12 @@ static void FreeDictInternalRep( Tcl_Obj *dictPtr) { - Dict *dict = dictPtr->internalRep.otherValuePtr; + Dict *dict = dictPtr->internalRep.twoPtrValue.ptr1; dict->refcount--; if (dict->refcount <= 0) { DeleteDict(dict); } - - dictPtr->internalRep.otherValuePtr = NULL; /* Belt and braces! */ dictPtr->typePtr = NULL; } @@ -487,15 +485,14 @@ static void UpdateStringOfDict( Tcl_Obj *dictPtr) { -#define LOCAL_SIZE 20 - int localFlags[LOCAL_SIZE], *flagPtr = NULL; - Dict *dict = dictPtr->internalRep.otherValuePtr; +#define LOCAL_SIZE 64 + char localFlags[LOCAL_SIZE], *flagPtr = NULL; + Dict *dict = dictPtr->internalRep.twoPtrValue.ptr1; ChainEntry *cPtr; Tcl_Obj *keyPtr, *valuePtr; int i, length, bytesNeeded = 0; const char *elem; char *dst; - const int maxFlags = UINT_MAX / sizeof(int); /* * This field is the most useful one in the whole hash structure, and it @@ -517,10 +514,8 @@ UpdateStringOfDict( if (numElems <= LOCAL_SIZE) { flagPtr = localFlags; - } else if (numElems > maxFlags) { - Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } else { - flagPtr = ckalloc(numElems * sizeof(int)); + flagPtr = ckalloc(numElems); } for (i=0,cPtr=dict->entryChainHead; i<numElems; i+=2,cPtr=cPtr->nextPtr) { /* @@ -624,7 +619,7 @@ SetDictFromAny( } for (i=0 ; i<objc ; i+=2) { - + /* Store key and value in the hash table we're building. */ hPtr = CreateChainEntry(dict, objv[i], &isNew); if (!isNew) { @@ -715,7 +710,7 @@ SetDictFromAny( dict->epoch = 0; dict->chain = NULL; dict->refcount = 1; - objPtr->internalRep.otherValuePtr = dict; + objPtr->internalRep.twoPtrValue.ptr1 = dict; objPtr->typePtr = &tclDictType; return TCL_OK; @@ -784,7 +779,7 @@ TclTraceDictPath( return NULL; } } - dict = dictPtr->internalRep.otherValuePtr; + dict = dictPtr->internalRep.twoPtrValue.ptr1; if (flags & DICT_PATH_UPDATE) { dict->chain = NULL; } @@ -827,7 +822,7 @@ TclTraceDictPath( } } - newDict = tmpObj->internalRep.otherValuePtr; + newDict = tmpObj->internalRep.twoPtrValue.ptr1; if (flags & DICT_PATH_UPDATE) { if (Tcl_IsShared(tmpObj)) { TclDecrRefCount(tmpObj); @@ -835,7 +830,7 @@ TclTraceDictPath( Tcl_IncrRefCount(tmpObj); Tcl_SetHashValue(hPtr, tmpObj); dict->epoch++; - newDict = tmpObj->internalRep.otherValuePtr; + newDict = tmpObj->internalRep.twoPtrValue.ptr1; } newDict->chain = dictPtr; @@ -870,17 +865,17 @@ static void InvalidateDictChain( Tcl_Obj *dictObj) { - Dict *dict = dictObj->internalRep.otherValuePtr; + Dict *dict = dictObj->internalRep.twoPtrValue.ptr1; do { - Tcl_InvalidateStringRep(dictObj); + TclInvalidateStringRep(dictObj); dict->epoch++; dictObj = dict->chain; if (dictObj == NULL) { break; } dict->chain = NULL; - dict = dictObj->internalRep.otherValuePtr; + dict = dictObj->internalRep.twoPtrValue.ptr1; } while (dict != NULL); } @@ -927,9 +922,9 @@ Tcl_DictObjPut( } if (dictPtr->bytes != NULL) { - Tcl_InvalidateStringRep(dictPtr); + TclInvalidateStringRep(dictPtr); } - dict = dictPtr->internalRep.otherValuePtr; + dict = dictPtr->internalRep.twoPtrValue.ptr1; hPtr = CreateChainEntry(dict, keyPtr, &isNew); Tcl_IncrRefCount(valuePtr); if (!isNew) { @@ -980,7 +975,7 @@ Tcl_DictObjGet( } } - dict = dictPtr->internalRep.otherValuePtr; + dict = dictPtr->internalRep.twoPtrValue.ptr1; hPtr = Tcl_FindHashEntry(&dict->table, keyPtr); if (hPtr == NULL) { *valuePtrPtr = NULL; @@ -1029,9 +1024,9 @@ Tcl_DictObjRemove( } if (dictPtr->bytes != NULL) { - Tcl_InvalidateStringRep(dictPtr); + TclInvalidateStringRep(dictPtr); } - dict = dictPtr->internalRep.otherValuePtr; + dict = dictPtr->internalRep.twoPtrValue.ptr1; if (DeleteChainEntry(dict, keyPtr)) { dict->epoch++; } @@ -1071,7 +1066,7 @@ Tcl_DictObjSize( } } - dict = dictPtr->internalRep.otherValuePtr; + dict = dictPtr->internalRep.twoPtrValue.ptr1; *sizePtr = dict->table.numEntries; return TCL_OK; } @@ -1126,7 +1121,7 @@ Tcl_DictObjFirst( } } - dict = dictPtr->internalRep.otherValuePtr; + dict = dictPtr->internalRep.twoPtrValue.ptr1; cPtr = dict->entryChainHead; if (cPtr == NULL) { searchPtr->epoch = -1; @@ -1301,7 +1296,7 @@ Tcl_DictObjPutKeyList( return TCL_ERROR; } - dict = dictPtr->internalRep.otherValuePtr; + dict = dictPtr->internalRep.twoPtrValue.ptr1; hPtr = CreateChainEntry(dict, keyv[keyc-1], &isNew); Tcl_IncrRefCount(valuePtr); if (!isNew) { @@ -1357,7 +1352,7 @@ Tcl_DictObjRemoveKeyList( return TCL_ERROR; } - dict = dictPtr->internalRep.otherValuePtr; + dict = dictPtr->internalRep.twoPtrValue.ptr1; DeleteChainEntry(dict, keyv[keyc-1]); InvalidateDictChain(dictPtr); return TCL_OK; @@ -1397,13 +1392,13 @@ Tcl_NewDictObj(void) Dict *dict; TclNewObj(dictPtr); - Tcl_InvalidateStringRep(dictPtr); + TclInvalidateStringRep(dictPtr); dict = ckalloc(sizeof(Dict)); InitChainTable(dict); dict->epoch = 0; dict->chain = NULL; dict->refcount = 1; - dictPtr->internalRep.otherValuePtr = dict; + dictPtr->internalRep.twoPtrValue.ptr1 = dict; dictPtr->typePtr = &tclDictType; return dictPtr; #endif @@ -1446,13 +1441,13 @@ Tcl_DbNewDictObj( Dict *dict; TclDbNewObj(dictPtr, file, line); - Tcl_InvalidateStringRep(dictPtr); + TclInvalidateStringRep(dictPtr); dict = ckalloc(sizeof(Dict)); InitChainTable(dict); dict->epoch = 0; dict->chain = NULL; dict->refcount = 1; - dictPtr->internalRep.otherValuePtr = dict; + dictPtr->internalRep.twoPtrValue.ptr1 = dict; dictPtr->typePtr = &tclDictType; return dictPtr; #else /* !TCL_MEM_DEBUG */ @@ -1974,7 +1969,7 @@ DictSizeCmd( } result = Tcl_DictObjSize(interp, objv[1], &size); if (result == TCL_OK) { - Tcl_SetObjResult(interp, Tcl_NewIntObj(size)); + Tcl_SetObjResult(interp, Tcl_NewLongObj(size)); } return result; } @@ -2016,9 +2011,9 @@ DictExistsCmd( if (dictPtr == NULL || dictPtr == DICT_PATH_NON_EXISTENT || Tcl_DictObjGet(interp, dictPtr, objv[objc-1], &valuePtr) != TCL_OK) { - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); + Tcl_SetObjResult(interp, Tcl_NewLongObj(0)); } else { - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(valuePtr != NULL)); + Tcl_SetObjResult(interp, Tcl_NewLongObj(valuePtr != NULL)); } return TCL_OK; } @@ -2064,7 +2059,7 @@ DictInfoCmd( return result; } } - dict = dictPtr->internalRep.otherValuePtr; + dict = dictPtr->internalRep.twoPtrValue.ptr1; statsStr = Tcl_HashStats(&dict->table); Tcl_SetObjResult(interp, Tcl_NewStringObj(statsStr, -1)); @@ -2157,7 +2152,7 @@ DictIncrCmd( Tcl_DictObjPut(interp, dictPtr, objv[2], objv[3]); } } else { - Tcl_DictObjPut(interp, dictPtr, objv[2], Tcl_NewIntObj(1)); + Tcl_DictObjPut(interp, dictPtr, objv[2], Tcl_NewLongObj(1)); } } else { /* @@ -2171,7 +2166,7 @@ DictIncrCmd( if (objc == 4) { code = TclIncrObj(interp, valuePtr, objv[3]); } else { - Tcl_Obj *incrPtr = Tcl_NewIntObj(1); + Tcl_Obj *incrPtr = Tcl_NewLongObj(1); Tcl_IncrRefCount(incrPtr); code = TclIncrObj(interp, valuePtr, incrPtr); @@ -2179,7 +2174,7 @@ DictIncrCmd( } } if (code == TCL_OK) { - Tcl_InvalidateStringRep(dictPtr); + TclInvalidateStringRep(dictPtr); valuePtr = Tcl_ObjSetVar2(interp, objv[1], NULL, dictPtr, TCL_LEAVE_ERR_MSG); if (valuePtr == NULL) { @@ -2268,7 +2263,7 @@ DictLappendCmd( if (allocatedValue) { Tcl_DictObjPut(interp, dictPtr, objv[2], valuePtr); } else if (dictPtr->bytes != NULL) { - Tcl_InvalidateStringRep(dictPtr); + TclInvalidateStringRep(dictPtr); } resultPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, dictPtr, @@ -2916,8 +2911,8 @@ DictFilterCmd( Tcl_WrongNumArgs(interp, 1, objv, "dictionary filterType ?arg ...?"); return TCL_ERROR; } - if (Tcl_GetIndexFromObj(interp, objv[2], filters, "filterType", - 0, &index) != TCL_OK) { + if (Tcl_GetIndexFromObjStruct(interp, objv[2], filters, + sizeof(char *), "filterType", 0, &index) != TCL_OK) { return TCL_ERROR; } diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index d2c7bc8..27a443f 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -18,7 +18,7 @@ typedef size_t (LengthProc)(const char *src); * convert between various character sets and UTF-8. */ -typedef struct Encoding { +typedef struct { char *name; /* Name of encoding. Malloced because (1) hash * table entry that owns this encoding may be * freed prior to this encoding being freed, @@ -57,7 +57,7 @@ typedef struct Encoding { * encoding. */ -typedef struct TableEncodingData { +typedef struct { int fallback; /* Character (in this encoding) to substitute * when this encoding cannot represent a UTF-8 * character. */ @@ -91,7 +91,7 @@ typedef struct TableEncodingData { * for switching character sets. */ -typedef struct EscapeSubTable { +typedef struct { unsigned sequenceLen; /* Length of following string. */ char sequence[16]; /* Escape code that marks this encoding. */ char name[32]; /* Name for encoding. */ @@ -100,7 +100,7 @@ typedef struct EscapeSubTable { * yet. */ } EscapeSubTable; -typedef struct EscapeEncodingData { +typedef struct { int fallback; /* Character (in this encoding) to substitute * when this encoding cannot represent a UTF-8 * character. */ @@ -270,7 +270,7 @@ static int Iso88591ToUtfProc(ClientData clientData, int *dstCharsPtr); /* - * A Tcl_ObjType for holding a cached Tcl_Encoding in the otherValuePtr field + * A Tcl_ObjType for holding a cached Tcl_Encoding in the twoPtrValue.ptr1 field * of the intrep. This should help the lifetime of encodings be more useful. * See concerns raised in [Bug 1077262]. */ @@ -313,7 +313,7 @@ Tcl_GetEncodingFromObj( return TCL_ERROR; } TclFreeIntRep(objPtr); - objPtr->internalRep.otherValuePtr = encoding; + objPtr->internalRep.twoPtrValue.ptr1 = encoding; objPtr->typePtr = &encodingType; } *encodingPtr = Tcl_GetEncoding(NULL, name); @@ -334,7 +334,7 @@ static void FreeEncodingIntRep( Tcl_Obj *objPtr) { - Tcl_FreeEncoding(objPtr->internalRep.otherValuePtr); + Tcl_FreeEncoding(objPtr->internalRep.twoPtrValue.ptr1); objPtr->typePtr = NULL; } @@ -353,7 +353,7 @@ DupEncodingIntRep( Tcl_Obj *srcPtr, Tcl_Obj *dupPtr) { - dupPtr->internalRep.otherValuePtr = Tcl_GetEncoding(NULL, srcPtr->bytes); + dupPtr->internalRep.twoPtrValue.ptr1 = Tcl_GetEncoding(NULL, srcPtr->bytes); } /* diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index b76c603..03f5edf 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. @@ -78,6 +87,17 @@ const Tcl_ObjType tclEnsembleCmdType = { StringOfEnsembleCmdRep, /* updateStringProc */ NULL /* setFromAnyProc */ }; + +/* + * Copied from tclCompCmds.c + */ + +#define DefineLineInformation \ + ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \ + int eclIndex = mapPtr->nuloc - 1 +#define SetLineInformation(word) \ + envPtr->line = mapPtr->loc[eclIndex].line[(word)]; \ + envPtr->clNext = mapPtr->loc[eclIndex].next[(word)] static inline Tcl_Obj * NewNsObj( @@ -142,8 +162,8 @@ TclNamespaceEnsembleCmd( Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg ...?"); return TCL_ERROR; } - if (Tcl_GetIndexFromObj(interp, objv[1], ensembleSubcommands, - "subcommand", 0, &index) != TCL_OK) { + if (Tcl_GetIndexFromObjStruct(interp, objv[1], ensembleSubcommands, + sizeof(char *), "subcommand", 0, &index) != TCL_OK) { return TCL_ERROR; } @@ -187,8 +207,8 @@ TclNamespaceEnsembleCmd( */ for (; objc>1 ; objc-=2,objv+=2) { - if (Tcl_GetIndexFromObj(interp, objv[0], ensembleCreateOptions, - "option", 0, &index) != TCL_OK) { + if (Tcl_GetIndexFromObjStruct(interp, objv[0], ensembleCreateOptions, + sizeof(char *), "option", 0, &index) != TCL_OK) { if (allocatedMapFlag) { Tcl_DecrRefCount(mapObj); } @@ -361,8 +381,8 @@ TclNamespaceEnsembleCmd( if (objc == 4) { Tcl_Obj *resultObj = NULL; /* silence gcc 4 warning */ - if (Tcl_GetIndexFromObj(interp, objv[3], ensembleConfigOptions, - "option", 0, &index) != TCL_OK) { + if (Tcl_GetIndexFromObjStruct(interp, objv[3], ensembleConfigOptions, + sizeof(char *), "option", 0, &index) != TCL_OK) { return TCL_ERROR; } switch ((enum EnsConfigOpts) index) { @@ -482,8 +502,8 @@ TclNamespaceEnsembleCmd( */ for (; objc>0 ; objc-=2,objv+=2) { - if (Tcl_GetIndexFromObj(interp, objv[0],ensembleConfigOptions, - "option", 0, &index) != TCL_OK) { + if (Tcl_GetIndexFromObjStruct(interp, objv[0],ensembleConfigOptions, + sizeof(char *), "option", 0, &index) != TCL_OK) { freeMapAndError: if (allocatedMapFlag) { Tcl_DecrRefCount(mapObj); @@ -1565,21 +1585,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; } @@ -1696,7 +1718,7 @@ NsEnsembleImplementationCmdNR( if (objv[1+ensemblePtr->numParameters]->typePtr==&tclEnsembleCmdType){ EnsembleCmdRep *ensembleCmd = objv[1+ensemblePtr->numParameters] - ->internalRep.otherValuePtr; + ->internalRep.twoPtrValue.ptr1; if (ensembleCmd->nsPtr == ensemblePtr->nsPtr && ensembleCmd->epoch == ensemblePtr->epoch && @@ -1892,7 +1914,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 +2122,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 +2196,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 { @@ -2216,7 +2238,7 @@ MakeCachedEnsembleCommand( int length; if (objPtr->typePtr == &tclEnsembleCmdType) { - ensembleCmd = objPtr->internalRep.otherValuePtr; + ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1; Tcl_DecrRefCount(ensembleCmd->realPrefixObj); TclNsDecrRefCount(ensembleCmd->nsPtr); ckfree(ensembleCmd->fullSubcmdName); @@ -2228,7 +2250,7 @@ MakeCachedEnsembleCommand( TclFreeIntRep(objPtr); ensembleCmd = ckalloc(sizeof(EnsembleCmdRep)); - objPtr->internalRep.otherValuePtr = ensembleCmd; + objPtr->internalRep.twoPtrValue.ptr1 = ensembleCmd; objPtr->typePtr = &tclEnsembleCmdType; } @@ -2623,7 +2645,7 @@ static void FreeEnsembleCmdRep( Tcl_Obj *objPtr) { - EnsembleCmdRep *ensembleCmd = objPtr->internalRep.otherValuePtr; + EnsembleCmdRep *ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1; Tcl_DecrRefCount(ensembleCmd->realPrefixObj); ckfree(ensembleCmd->fullSubcmdName); @@ -2655,12 +2677,12 @@ DupEnsembleCmdRep( Tcl_Obj *objPtr, Tcl_Obj *copyPtr) { - EnsembleCmdRep *ensembleCmd = objPtr->internalRep.otherValuePtr; + EnsembleCmdRep *ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1; EnsembleCmdRep *ensembleCopy = ckalloc(sizeof(EnsembleCmdRep)); int length = strlen(ensembleCmd->fullSubcmdName); copyPtr->typePtr = &tclEnsembleCmdType; - copyPtr->internalRep.otherValuePtr = ensembleCopy; + copyPtr->internalRep.twoPtrValue.ptr1 = ensembleCopy; ensembleCopy->nsPtr = ensembleCmd->nsPtr; ensembleCopy->epoch = ensembleCmd->epoch; ensembleCopy->token = ensembleCmd->token; @@ -2693,7 +2715,7 @@ static void StringOfEnsembleCmdRep( Tcl_Obj *objPtr) { - EnsembleCmdRep *ensembleCmd = objPtr->internalRep.otherValuePtr; + EnsembleCmdRep *ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1; int length = strlen(ensembleCmd->fullSubcmdName); objPtr->length = length; @@ -2731,25 +2753,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 +2798,7 @@ TclCompileEnsemble( * to proceed. */ - return TCL_ERROR; + goto failed; } /* @@ -2782,7 +2812,7 @@ TclCompileEnsemble( * Figuring out how to compile this has become too much. Bail out. */ - return TCL_ERROR; + goto failed; } /* @@ -2805,7 +2835,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 +2846,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 +2864,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 +2888,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 +2904,7 @@ TclCompileEnsemble( */ if (!(flags & TCL_ENSEMBLE_PREFIX)) { - return TCL_ERROR; + goto failed; } /* @@ -2881,6 +2914,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 +2925,7 @@ TclCompileEnsemble( break; } + replacement = subcmdObj; targetCmdObj = tmpObj; } Tcl_DictObjNext(&s, &subcmdObj, &tmpObj, &done); @@ -2903,7 +2938,8 @@ TclCompileEnsemble( */ if (matched != 1) { - return TCL_ERROR; + invokeAnyway = 1; + goto failed; } } @@ -2917,75 +2953,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; + } + + /* + * 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; +} + +/* + * 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; - 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; + if (cmdPtr->compileProc == NULL) { + return TCL_ERROR; + } - 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; + 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 +3113,428 @@ 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( + TclFetchLiteral(envPtr, literal), + 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, TclFetchLiteral(envPtr, cmdLit), cmdPtr); + TclEmitPush(cmdLit, envPtr); + TclDecrRefCount(objPtr); + + /* + * Do the replacing dispatch. + */ + + TclEmitInstInt4(INST_INVOKE_REPLACE, parsePtr->numWords, envPtr); + TclEmitInt1(numWords+1, envPtr); + 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, TclFetchLiteral(envPtr, literal), 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. + */ + + if (i <= 255) { + TclEmitInstInt1(INST_INVOKE_STK1, i, envPtr); + } else { + TclEmitInstInt4(INST_INVOKE_STK4, i, envPtr); + } + 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/tclEvent.c b/generic/tclEvent.c index 0b585b6..16e0bf3 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -37,7 +37,7 @@ typedef struct BgError { * pending background errors for the interpreter. */ -typedef struct ErrAssocData { +typedef struct { Tcl_Interp *interp; /* Interpreter in which error occurred. */ Tcl_Obj *cmdPrefix; /* First word(s) of the handler command */ BgError *firstBgPtr; /* First in list of all background errors @@ -891,7 +891,7 @@ Tcl_SetExitProc( *---------------------------------------------------------------------- */ static void -InvokeExitHandlers(void) +InvokeExitHandlers(void) { ExitHandler *exitPtr; @@ -967,22 +967,22 @@ Tcl_Exit( /* * Fast and deterministic exit (default behavior) */ - + InvokeExitHandlers(); - + /* * Ensure the thread-specific data is initialised as it is used in * Tcl_FinalizeThread() */ - + (void) TCL_TSD_INIT(&dataKey); - + /* * Now finalize the calling thread only (others are not safely * reachable). Among other things, this triggers a flush of the * Tcl_Channels that may have data enqueued. */ - + Tcl_FinalizeThread(); } TclpExit(status); @@ -1094,7 +1094,7 @@ Tcl_Finalize(void) * Invoke exit handlers first. */ - InvokeExitHandlers(); + InvokeExitHandlers(); TclpInitLock(); if (subsystemsInitialized == 0) { @@ -1402,7 +1402,7 @@ Tcl_VwaitObjCmd( return TCL_ERROR; } nameString = Tcl_GetString(objv[1]); - if (Tcl_TraceVar(interp, nameString, + if (Tcl_TraceVar2(interp, nameString, NULL, TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, VwaitVarProc, &done) != TCL_OK) { return TCL_ERROR; @@ -1420,7 +1420,7 @@ Tcl_VwaitObjCmd( break; } } - Tcl_UntraceVar(interp, nameString, + Tcl_UntraceVar2(interp, nameString, NULL, TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, VwaitVarProc, &done); @@ -1498,8 +1498,8 @@ Tcl_UpdateObjCmd( if (objc == 1) { flags = TCL_ALL_EVENTS|TCL_DONT_WAIT; } else if (objc == 2) { - if (Tcl_GetIndexFromObj(interp, objv[1], updateOptions, - "option", 0, &optionIndex) != TCL_OK) { + if (Tcl_GetIndexFromObjStruct(interp, objv[1], updateOptions, + sizeof(char *), "option", 0, &optionIndex) != TCL_OK) { return TCL_ERROR; } switch ((enum updateOptions) optionIndex) { diff --git a/generic/tclExecute.c b/generic/tclExecute.c index cb1864c40..b872bd9 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -114,7 +114,7 @@ long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 }; * Minimal data required to fully reconstruct the execution state. */ -typedef struct TEBCdata { +typedef struct { ByteCode *codePtr; /* Constant until the BC returns */ /* -----------------------------------------*/ const unsigned char *pc; /* These fields are used on return TO this */ @@ -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); \ @@ -628,7 +643,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); @@ -797,9 +812,9 @@ TclCreateExecEnv( + (size_t) (size-1) * sizeof(Tcl_Obj *)); eePtr->execStackPtr = esPtr; - TclNewBooleanObj(eePtr->constants[0], 0); + TclNewLongObj(eePtr->constants[0], 0); Tcl_IncrRefCount(eePtr->constants[0]); - TclNewBooleanObj(eePtr->constants[1], 1); + TclNewLongObj(eePtr->constants[1], 1); Tcl_IncrRefCount(eePtr->constants[1]); eePtr->interp = interp; eePtr->callbackPtr = NULL; @@ -991,6 +1006,7 @@ GrowEvaluationStack( return MEMSTART(markerPtr); } } else { +#ifndef PURIFY Tcl_Obj **tmpMarkerPtr = esPtr->tosPtr + 1; int offset = OFFSET(tmpMarkerPtr); @@ -1007,6 +1023,7 @@ GrowEvaluationStack( *esPtr->markerPtr = (Tcl_Obj *) markerPtr; return memStart; } +#endif } /* @@ -1020,6 +1037,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!) @@ -1049,10 +1067,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; @@ -1155,7 +1178,7 @@ TclStackFree( Tcl_Obj **markerPtr, *marker; if (iPtr == NULL || iPtr->execEnvPtr == NULL) { - Tcl_Free((char *) freePtr); + ckfree((char *) freePtr); return; } @@ -1201,6 +1224,10 @@ TclStackFree( } if (esPtr->prevPtr) { eePtr->execStackPtr = esPtr->prevPtr; +#ifdef PURIFY + eePtr->execStackPtr->nextPtr = NULL; + DeleteExecStack(esPtr); +#endif } else { eePtr->execStackPtr = esPtr; } @@ -1215,7 +1242,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); @@ -1234,7 +1261,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; @@ -1410,7 +1437,7 @@ CompileExprObj( if (objPtr->typePtr == &exprCodeType) { Namespace *namespacePtr = iPtr->varFramePtr->nsPtr; - codePtr = objPtr->internalRep.otherValuePtr; + codePtr = objPtr->internalRep.twoPtrValue.ptr1; if (((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) || (codePtr->nsPtr != namespacePtr) @@ -1450,7 +1477,7 @@ CompileExprObj( TclInitByteCodeObj(objPtr, &compEnv); objPtr->typePtr = &exprCodeType; TclFreeCompileEnv(&compEnv); - codePtr = objPtr->internalRep.otherValuePtr; + codePtr = objPtr->internalRep.twoPtrValue.ptr1; if (iPtr->varFramePtr->localCachePtr) { codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; codePtr->localCachePtr->refCount++; @@ -1522,10 +1549,9 @@ static void FreeExprCodeInternalRep( Tcl_Obj *objPtr) { - ByteCode *codePtr = objPtr->internalRep.otherValuePtr; + ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1; objPtr->typePtr = NULL; - objPtr->internalRep.otherValuePtr = NULL; codePtr->refCount--; if (codePtr->refCount <= 0) { TclCleanupByteCode(codePtr); @@ -1583,7 +1609,7 @@ TclCompileObj( * here. */ - codePtr = objPtr->internalRep.otherValuePtr; + codePtr = objPtr->internalRep.twoPtrValue.ptr1; if (((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) || (codePtr->nsPtr != namespacePtr) @@ -1711,7 +1737,7 @@ TclCompileObj( iPtr->invokeWord = word; TclSetByteCodeFromAny(interp, objPtr, NULL, NULL); iPtr->invokeCmdFramePtr = NULL; - codePtr = objPtr->internalRep.otherValuePtr; + codePtr = objPtr->internalRep.twoPtrValue.ptr1; if (iPtr->varFramePtr->localCachePtr) { codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; codePtr->localCachePtr->refCount++; @@ -2003,7 +2029,8 @@ TEBCresume( 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. @@ -2028,6 +2055,7 @@ TEBCresume( #endif #ifdef TCL_COMPILE_DEBUG + int starting = 1; traceInstructions = (tclTraceExec == 3); #endif @@ -2169,24 +2197,6 @@ TEBCresume( } 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). @@ -2218,8 +2228,6 @@ TEBCresume( CACHE_STACK_INFO(); } - TCL_DTRACE_INST_NEXT(); - /* * These two instructions account for 26% of all instructions (according * to measurements on tclbench by Ben Vitale @@ -2229,13 +2237,53 @@ TEBCresume( * reduces total obj size. */ - if (*pc == INST_LOAD_SCALAR1) { - goto instLoadScalar1; - } else if (*pc == INST_PUSH1) { - goto instPush1Peephole; + 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_SCALAR1) { + goto instLoadScalar1; + } else if (inst == INST_PUSH1) { + PUSH_OBJECT(codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)]); + TRACE_WITH_OBJ(("%u => ", TclGetInt1AtPtr(pc+1)), OBJ_AT_TOS); + inst = *(pc += 2); + 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); @@ -2319,7 +2367,6 @@ TEBCresume( case INST_TAILCALL: { Tcl_Obj *listPtr, *nsObjPtr; - NRE_callback *tailcallPtr; opnd = TclGetUInt1AtPtr(pc+1); @@ -2353,18 +2400,12 @@ TEBCresume( 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; @@ -2392,23 +2433,6 @@ TEBCresume( (void) POP_OBJECT(); goto abnormalReturn; - case INST_PUSH1: - instPush1Peephole: - PUSH_OBJECT(codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)]); - TRACE_WITH_OBJ(("%u => ", TclGetInt1AtPtr(pc+1)), OBJ_AT_TOS); - pc += 2; -#if !TCL_COMPILE_DEBUG - /* - * Runtime peephole optimisation: check if we are pushing again. - */ - - if (*pc == INST_PUSH1) { - TCL_DTRACE_INST_NEXT(); - goto instPush1Peephole; - } -#endif - NEXT_INST_F(0, 0, 0); - case INST_PUSH4: objResultPtr = codePtr->objArrayPtr[TclGetUInt4AtPtr(pc+1)]; TRACE_WITH_OBJ(("%u => ", TclGetUInt4AtPtr(pc+1)), objResultPtr); @@ -2418,68 +2442,10 @@ TEBCresume( TRACE_WITH_OBJ(("=> discarding "), OBJ_AT_TOS); objPtr = POP_OBJECT(); TclDecrRefCount(objPtr); - - /* - * 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 +2806,70 @@ TEBCresume( case INST_CALL_FUNC1: Tcl_Panic("TclNRExecuteByteCode: obsolete INST_CALL_FUNC1 found"); + 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. @@ -3301,8 +3331,8 @@ TEBCresume( 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; @@ -4134,7 +4164,7 @@ TEBCresume( NEXT_INST_F(1, 0, 1); } case INST_INFO_LEVEL_NUM: - TclNewIntObj(objResultPtr, iPtr->varFramePtr->level); + TclNewLongObj(objResultPtr, iPtr->varFramePtr->level); TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(1, 0, 1); case INST_INFO_LEVEL_ARGS: { @@ -4263,7 +4293,7 @@ TEBCresume( Tcl_GetObjResult(interp)); goto gotError; } - TclNewIntObj(objResultPtr, length); + TclNewLongObj(objResultPtr, length); TRACE(("%.20s => %d\n", O2S(valuePtr), length)); NEXT_INST_F(1, 1, 1); @@ -4730,7 +4760,7 @@ TEBCresume( } } if (match < 0) { - TclNewIntObj(objResultPtr, -1); + TclNewLongObj(objResultPtr, -1); } else { objResultPtr = TCONST(match > 0); } @@ -4741,7 +4771,7 @@ TEBCresume( case INST_STR_LEN: valuePtr = OBJ_AT_TOS; length = Tcl_GetCharLength(valuePtr); - TclNewIntObj(objResultPtr, length); + TclNewLongObj(objResultPtr, length); TRACE(("%.20s => %d\n", O2S(valuePtr), length)); NEXT_INST_F(1, 1, 1); @@ -4929,7 +4959,7 @@ TEBCresume( TRACE(("%.20s %.20s => %d\n", O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), match)); - TclNewIntObj(objResultPtr, match); + TclNewLongObj(objResultPtr, match); NEXT_INST_F(1, 2, 1); case INST_STR_FIND_LAST: @@ -4950,7 +4980,7 @@ TEBCresume( TRACE(("%.20s %.20s => %d\n", O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), match)); - TclNewIntObj(objResultPtr, match); + TclNewLongObj(objResultPtr, match); NEXT_INST_F(1, 2, 1); } @@ -5290,7 +5320,7 @@ TEBCresume( if (l1 > 0L) { objResultPtr = TCONST(0); } else { - TclNewIntObj(objResultPtr, -1); + TclNewLongObj(objResultPtr, -1); } TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); @@ -5972,7 +6002,7 @@ TEBCresume( NEXT_INST_F(1, 0, -1); case INST_PUSH_RETURN_CODE: - TclNewIntObj(objResultPtr, result); + TclNewLongObj(objResultPtr, result); TRACE(("=> %u\n", result)); NEXT_INST_F(1, 0, 1); @@ -6890,6 +6920,42 @@ TEBCresume( 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 @@ -8353,11 +8419,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; @@ -8375,13 +8440,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..036a82c 100644 --- a/generic/tclFCmd.c +++ b/generic/tclFCmd.c @@ -120,7 +120,7 @@ FileCopyRename( } i++; if ((objc - i) < 2) { - Tcl_WrongNumArgs(interp, 1, objv, + Tcl_WrongNumArgs(interp, 1, objv, "?-option value ...? source ?source ...? target"); return TCL_ERROR; } @@ -831,8 +831,8 @@ FileForceOption( if (TclGetString(objv[i])[0] != '-') { break; } - if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", TCL_EXACT, - &idx) != TCL_OK) { + if (Tcl_GetIndexFromObjStruct(interp, objv[i], options, + sizeof(char *), "option", TCL_EXACT, &idx) != TCL_OK) { return -1; } if (idx == 0 /* -force */) { @@ -1081,8 +1081,8 @@ TclFileAttrsCmd( goto end; } - if (Tcl_GetIndexFromObj(interp, objv[0], attributeStrings, - "option", 0, &index) != TCL_OK) { + if (Tcl_GetIndexFromObjStruct(interp, objv[0], attributeStrings, + sizeof(char *), "option", 0, &index) != TCL_OK) { goto end; } if (attributeStringsAllocated != NULL) { @@ -1109,8 +1109,8 @@ TclFileAttrsCmd( } for (i = 0; i < objc ; i += 2) { - if (Tcl_GetIndexFromObj(interp, objv[i], attributeStrings, - "option", 0, &index) != TCL_OK) { + if (Tcl_GetIndexFromObjStruct(interp, objv[i], attributeStrings, + sizeof(char *), "option", 0, &index) != TCL_OK) { goto end; } if (attributeStringsAllocated != NULL) { @@ -1199,8 +1199,8 @@ TclFileLinkCmd( static const char *const linkTypes[] = { "-symbolic", "-hard", NULL }; - if (Tcl_GetIndexFromObj(interp, objv[1], linkTypes, "switch", 0, - &linkAction) != TCL_OK) { + if (Tcl_GetIndexFromObjStruct(interp, objv[1], linkTypes, + sizeof(char *), "switch", 0, &linkAction) != TCL_OK) { return TCL_ERROR; } if (linkAction == 0) { diff --git a/generic/tclFileName.c b/generic/tclFileName.c index a519f0e..847a97a 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -1256,8 +1256,8 @@ Tcl_GlobObjCmd( dir = PATH_NONE; typePtr = NULL; for (i = 1; i < objc; i++) { - if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, - &index) != TCL_OK) { + if (Tcl_GetIndexFromObjStruct(interp, objv[i], options, + sizeof(char *), "option", 0, &index) != TCL_OK) { string = Tcl_GetStringFromObj(objv[i], &length); if (string[0] == '-') { /* diff --git a/generic/tclGet.c b/generic/tclGet.c index 4c19b55..97e8c7b 100644 --- a/generic/tclGet.c +++ b/generic/tclGet.c @@ -137,7 +137,7 @@ Tcl_GetBoolean( obj.length = strlen(src); obj.typePtr = NULL; - code = Tcl_ConvertToType(interp, &obj, &tclBooleanType); + code = TclSetBooleanFromAny(interp, &obj); if (obj.refCount > 1) { Tcl_Panic("invalid sharing of Tcl_Obj on C stack"); } diff --git a/generic/tclIO.c b/generic/tclIO.c index 0568d77..8e2c405 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -16,6 +16,108 @@ #include <assert.h> /* + * For each channel handler registered in a call to Tcl_CreateChannelHandler, + * there is one record of the following type. All of records for a specific + * channel are chained together in a singly linked list which is stored in + * the channel structure. + */ + +typedef struct ChannelHandler { + Channel *chanPtr; /* The channel structure for this channel. */ + int mask; /* Mask of desired events. */ + Tcl_ChannelProc *proc; /* Procedure to call in the type of + * Tcl_CreateChannelHandler. */ + ClientData clientData; /* Argument to pass to procedure. */ + struct ChannelHandler *nextPtr; + /* Next one in list of registered handlers. */ +} ChannelHandler; + +/* + * This structure keeps track of the current ChannelHandler being invoked in + * the current invocation of ChannelHandlerEventProc. There is a potential + * problem if a ChannelHandler is deleted while it is the current one, since + * ChannelHandlerEventProc needs to look at the nextPtr field. To handle this + * problem, structures of the type below indicate the next handler to be + * processed for any (recursively nested) dispatches in progress. The + * nextHandlerPtr field is updated if the handler being pointed to is deleted. + * The nextPtr field is used to chain together all recursive invocations, so + * that Tcl_DeleteChannelHandler can find all the recursively nested + * invocations of ChannelHandlerEventProc and compare the handler being + * deleted against the NEXT handler to be invoked in that invocation; when it + * finds such a situation, Tcl_DeleteChannelHandler updates the nextHandlerPtr + * field of the structure to the next handler. + */ + +typedef struct NextChannelHandler { + ChannelHandler *nextHandlerPtr; /* The next handler to be invoked in + * this invocation. */ + struct NextChannelHandler *nestedHandlerPtr; + /* Next nested invocation of + * ChannelHandlerEventProc. */ +} NextChannelHandler; + +/* + * The following structure describes the event that is added to the Tcl + * event queue by the channel handler check procedure. + */ + +typedef struct ChannelHandlerEvent { + Tcl_Event header; /* Standard header for all events. */ + Channel *chanPtr; /* The channel that is ready. */ + int readyMask; /* Events that have occurred. */ +} ChannelHandlerEvent; + +/* + * The following structure is used by Tcl_GetsObj() to encapsulates the + * state for a "gets" operation. + */ + +typedef struct GetsState { + Tcl_Obj *objPtr; /* The object to which UTF-8 characters + * will be appended. */ + char **dstPtr; /* Pointer into objPtr's string rep where + * next character should be stored. */ + Tcl_Encoding encoding; /* The encoding to use to convert raw bytes + * to UTF-8. */ + ChannelBuffer *bufPtr; /* The current buffer of raw bytes being + * emptied. */ + Tcl_EncodingState state; /* The encoding state just before the last + * external to UTF-8 conversion in + * FilterInputBytes(). */ + int rawRead; /* The number of bytes removed from bufPtr + * in the last call to FilterInputBytes(). */ + int bytesWrote; /* The number of bytes of UTF-8 data + * appended to objPtr during the last call to + * FilterInputBytes(). */ + int charsWrote; /* The corresponding number of UTF-8 + * characters appended to objPtr during the + * last call to FilterInputBytes(). */ + int totalChars; /* The total number of UTF-8 characters + * appended to objPtr so far, just before the + * last call to FilterInputBytes(). */ +} GetsState; + +/* + * The following structure encapsulates the state for a background channel + * copy. Note that the data buffer for the copy will be appended to this + * structure. + */ + +typedef struct CopyState { + struct Channel *readPtr; /* Pointer to input channel. */ + struct Channel *writePtr; /* Pointer to output channel. */ + int readFlags; /* Original read channel flags. */ + int writeFlags; /* Original write channel flags. */ + Tcl_WideInt toRead; /* Number of bytes to copy, or -1. */ + Tcl_WideInt total; /* Total bytes transferred (written). */ + Tcl_Interp *interp; /* Interp that started the copy. */ + Tcl_Obj *cmdPtr; /* Command to be invoked at completion. */ + int bufSize; /* Size of appended buffer. */ + char buffer[1]; /* Copy buffer, this must be the last + * field. */ +} CopyState; + +/* * All static variables used in this file are collected into a single instance * of the following structure. For multi-threaded implementations, there is * one instance of this structure for each thread. @@ -24,7 +126,7 @@ * The structure defined below is used in this file only. */ -typedef struct ThreadSpecificData { +typedef struct { NextChannelHandler *nestedHandlerPtr; /* This variable holds the list of nested * ChannelHandlerEventProc invocations. */ @@ -44,6 +146,18 @@ typedef struct ThreadSpecificData { static Tcl_ThreadDataKey dataKey; /* + * Structure to record a close callback. One such record exists for + * each close callback registered for a channel. + */ + +typedef struct CloseCallback { + Tcl_CloseProc *proc; /* The procedure to call. */ + ClientData clientData; /* Arbitrary one-word data to pass + * to the callback. */ + struct CloseCallback *nextPtr; /* For chaining close callbacks. */ +} CloseCallback; + +/* * Static functions in this file: */ @@ -221,9 +335,9 @@ static const Tcl_ObjType tclChannelType = { }; #define GET_CHANNELSTATE(objPtr) \ - ((ChannelState *) (objPtr)->internalRep.otherValuePtr) + ((ChannelState *) (objPtr)->internalRep.twoPtrValue.ptr1) #define SET_CHANNELSTATE(objPtr, storePtr) \ - ((objPtr)->internalRep.otherValuePtr = (void *) (storePtr)) + ((objPtr)->internalRep.twoPtrValue.ptr1 = (void *) (storePtr)) #define GET_CHANNELINTERP(objPtr) \ ((Interp *) (objPtr)->internalRep.twoPtrValue.ptr2) #define SET_CHANNELINTERP(objPtr, storePtr) \ @@ -398,11 +512,11 @@ TclFinalizeIOSubsystem(void) int active = 1; /* Flag == 1 while there's still work to do */ int doflushnb; - /* Fetch the pre-TIP#398 compatibility flag */ + /* Fetch the pre-TIP#398 compatibility flag */ { const char *s; Tcl_DString ds; - + s = TclGetEnv("TCL_FLUSH_NONBLOCKING_ON_EXIT", &ds); doflushnb = ((s != NULL) && strcmp(s, "0")); if (s != NULL) { @@ -454,9 +568,9 @@ TclFinalizeIOSubsystem(void) /* Set the channel back into blocking mode to ensure that we wait * for all data to flush out. */ - + (void) Tcl_SetChannelOption(NULL, (Tcl_Channel) chanPtr, - "-blocking", "on"); + "-blocking", "on"); } if ((chanPtr == (Channel *) tsdPtr->stdinChannel) || @@ -695,6 +809,8 @@ Tcl_DeleteCloseHandler( if ((cbPtr->proc == proc) && (cbPtr->clientData == clientData)) { if (cbPrevPtr == NULL) { statePtr->closeCbPtr = cbPtr->nextPtr; + } else { + cbPrevPtr->nextPtr = cbPtr->nextPtr; } ckfree(cbPtr); break; @@ -8860,8 +8976,8 @@ Tcl_FileEventObjCmd( Tcl_WrongNumArgs(interp, 1, objv, "channelId event ?script?"); return TCL_ERROR; } - if (Tcl_GetIndexFromObj(interp, objv[2], modeOptions, "event name", 0, - &modeIndex) != TCL_OK) { + if (Tcl_GetIndexFromObjStruct(interp, objv[2], modeOptions, + sizeof(char *), "event name", 0, &modeIndex) != TCL_OK) { return TCL_ERROR; } mask = maskArray[modeIndex]; diff --git a/generic/tclIO.h b/generic/tclIO.h index 1e89878..e84f300 100644 --- a/generic/tclIO.h +++ b/generic/tclIO.h @@ -30,26 +30,6 @@ #endif /* - * The following structure encapsulates the state for a background channel - * copy. Note that the data buffer for the copy will be appended to this - * structure. - */ - -typedef struct CopyState { - struct Channel *readPtr; /* Pointer to input channel. */ - struct Channel *writePtr; /* Pointer to output channel. */ - int readFlags; /* Original read channel flags. */ - int writeFlags; /* Original write channel flags. */ - Tcl_WideInt toRead; /* Number of bytes to copy, or -1. */ - Tcl_WideInt total; /* Total bytes transferred (written). */ - Tcl_Interp *interp; /* Interp that started the copy. */ - Tcl_Obj *cmdPtr; /* Command to be invoked at completion. */ - int bufSize; /* Size of appended buffer. */ - char buffer[1]; /* Copy buffer, this must be the last - * field. */ -} CopyState; - -/* * struct ChannelBuffer: * * Buffers data being sent to or from a channel. @@ -86,19 +66,6 @@ typedef struct ChannelBuffer { #define CHANNELBUFFER_DEFAULT_SIZE (1024 * 4) /* - * Structure to record a close callback. One such record exists for each close - * callback registered for a channel. - */ - -typedef struct CloseCallback { - Tcl_CloseProc *proc; /* The procedure to call. */ - ClientData clientData; /* Arbitrary one-word data to pass to the - * callback. */ - struct CloseCallback *nextPtr; - /* For chaining close callbacks. */ -} CloseCallback; - -/* * The following structure describes the information saved from a call to * "fileevent". This is used later when the event being waited for to invoke * the saved script in the interpreter designed in this record. @@ -195,7 +162,8 @@ typedef struct ChannelState { * value is the POSIX error code. */ int refCount; /* How many interpreters hold references to * this IO channel? */ - CloseCallback *closeCbPtr; /* Callbacks registered to be called when the + struct CloseCallback *closeCbPtr; + /* Callbacks registered to be called when the * channel is closed. */ char *outputStage; /* Temporary staging buffer used when * translating EOL before converting from @@ -217,8 +185,10 @@ typedef struct ChannelState { * handlers ("fileevent") on this channel. */ int bufSize; /* What size buffers to allocate? */ Tcl_TimerToken timer; /* Handle to wakeup timer for this channel. */ - CopyState *csPtrR; /* State of background copy for which channel is input, or NULL. */ - CopyState *csPtrW; /* State of background copy for which channel is output, or NULL. */ + struct CopyState *csPtrR; /* State of background copy for which channel + * is input, or NULL. */ + struct CopyState *csPtrW; /* State of background copy for which channel + * is output, or NULL. */ Channel *topChanPtr; /* Refers to topmost channel in a stack. Never * NULL. */ Channel *bottomChanPtr; /* Refers to bottommost channel in a stack. @@ -342,89 +312,6 @@ typedef struct ChannelState { * the channel is allowed. */ /* - * For each channel handler registered in a call to Tcl_CreateChannelHandler, - * there is one record of the following type. All of records for a specific - * channel are chained together in a singly linked list which is stored in the - * channel structure. - */ - -typedef struct ChannelHandler { - Channel *chanPtr; /* The channel structure for this channel. */ - int mask; /* Mask of desired events. */ - Tcl_ChannelProc *proc; /* Procedure to call in the type of - * Tcl_CreateChannelHandler. */ - ClientData clientData; /* Argument to pass to procedure. */ - struct ChannelHandler *nextPtr; - /* Next one in list of registered handlers. */ -} ChannelHandler; - -/* - * This structure keeps track of the current ChannelHandler being invoked in - * the current invocation of ChannelHandlerEventProc. There is a potential - * problem if a ChannelHandler is deleted while it is the current one, since - * ChannelHandlerEventProc needs to look at the nextPtr field. To handle this - * problem, structures of the type below indicate the next handler to be - * processed for any (recursively nested) dispatches in progress. The - * nextHandlerPtr field is updated if the handler being pointed to is deleted. - * The nextPtr field is used to chain together all recursive invocations, so - * that Tcl_DeleteChannelHandler can find all the recursively nested - * invocations of ChannelHandlerEventProc and compare the handler being - * deleted against the NEXT handler to be invoked in that invocation; when it - * finds such a situation, Tcl_DeleteChannelHandler updates the nextHandlerPtr - * field of the structure to the next handler. - */ - -typedef struct NextChannelHandler { - ChannelHandler *nextHandlerPtr; - /* The next handler to be invoked in this - * invocation. */ - struct NextChannelHandler *nestedHandlerPtr; - /* Next nested invocation of - * ChannelHandlerEventProc. */ -} NextChannelHandler; - -/* - * The following structure describes the event that is added to the Tcl event - * queue by the channel handler check procedure. - */ - -typedef struct ChannelHandlerEvent { - Tcl_Event header; /* Standard header for all events. */ - Channel *chanPtr; /* The channel that is ready. */ - int readyMask; /* Events that have occurred. */ -} ChannelHandlerEvent; - -/* - * The following structure is used by Tcl_GetsObj() to encapsulates the state - * for a "gets" operation. - */ - -typedef struct GetsState { - Tcl_Obj *objPtr; /* The object to which UTF-8 characters will - * be appended. */ - char **dstPtr; /* Pointer into objPtr's string rep where next - * character should be stored. */ - Tcl_Encoding encoding; /* The encoding to use to convert raw bytes to - * UTF-8. */ - ChannelBuffer *bufPtr; /* The current buffer of raw bytes being - * emptied. */ - Tcl_EncodingState state; /* The encoding state just before the last - * external to UTF-8 conversion in - * FilterInputBytes(). */ - int rawRead; /* The number of bytes removed from bufPtr in - * the last call to FilterInputBytes(). */ - int bytesWrote; /* The number of bytes of UTF-8 data appended - * to objPtr during the last call to - * FilterInputBytes(). */ - int charsWrote; /* The corresponding number of UTF-8 - * characters appended to objPtr during the - * last call to FilterInputBytes(). */ - int totalChars; /* The total number of UTF-8 characters - * appended to objPtr so far, just before the - * last call to FilterInputBytes(). */ -} GetsState; - -/* * The length of time to wait between synthetic timer events. Must be zero or * bad things tend to happen. */ diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index 27f156f..8f561b0 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -15,7 +15,7 @@ * Callback structure for accept callback in a TCP server. */ -typedef struct AcceptCallback { +typedef struct { char *script; /* Script to invoke. */ Tcl_Interp *interp; /* Interpreter in which to run it. */ } AcceptCallback; @@ -25,7 +25,7 @@ typedef struct AcceptCallback { * It must be per-thread because of std channel limitations. */ -typedef struct ThreadSpecificData { +typedef struct { int initialized; /* Set to 1 when the module is initialized. */ Tcl_Obj *stdoutObjPtr; /* Cached stdout channel Tcl_Obj */ } ThreadSpecificData; @@ -1929,25 +1929,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/tclIORChan.c b/generic/tclIORChan.c index cb0282a..4b61538 100644 --- a/generic/tclIORChan.c +++ b/generic/tclIORChan.c @@ -256,7 +256,7 @@ typedef enum { * sharing problems. */ -typedef struct ForwardParamBase { +typedef struct { int code; /* O: Ok/Fail of the cmd handler */ char *msgStr; /* O: Error message for handler failure */ int mustFree; /* O: True if msgStr is allocated, false if @@ -331,7 +331,7 @@ typedef struct ForwardingResult ForwardingResult; * General event structure, with reference to operation specific data. */ -typedef struct ForwardingEvent { +typedef struct { Tcl_Event event; /* Basic event data, has to be first item */ ForwardingResult *resultPtr; ForwardedOperation op; /* Forwarded driver operation */ @@ -368,7 +368,7 @@ struct ForwardingResult { * results. */ }; -typedef struct ThreadSpecificData { +typedef struct { /* * Table of all reflected channels owned by this thread. This is the * per-thread version of the per-interpreter map. @@ -774,7 +774,7 @@ TclChanCreateObjCmd( *---------------------------------------------------------------------- */ -typedef struct ReflectEvent { +typedef struct { Tcl_Event header; ReflectedChannel *rcPtr; int events; diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c index 2b9efb9..2ab634c 100644 --- a/generic/tclIORTrans.c +++ b/generic/tclIORTrans.c @@ -87,7 +87,7 @@ static const Tcl_ChannelType tclRTransformType = { * layers upon reading from the channel, plus the functions to manage such. */ -typedef struct _ResultBuffer_ { +typedef struct { unsigned char *buf; /* Reference to the buffer area. */ int allocated; /* Allocated size of the buffer area. */ int used; /* Number of bytes in the buffer, @@ -252,7 +252,7 @@ typedef enum { * sharing problems. */ -typedef struct ForwardParamBase { +typedef struct { int code; /* O: Ok/Fail of the cmd handler */ char *msgStr; /* O: Error message for handler failure */ int mustFree; /* O: True if msgStr is allocated, false if @@ -297,7 +297,7 @@ typedef struct ForwardingResult ForwardingResult; * General event structure, with reference to operation specific data. */ -typedef struct ForwardingEvent { +typedef struct { Tcl_Event event; /* Basic event data, has to be first item */ ForwardingResult *resultPtr; ForwardedOperation op; /* Forwarded driver operation */ @@ -328,7 +328,7 @@ struct ForwardingResult { * results. */ }; -typedef struct ThreadSpecificData { +typedef struct { /* * Table of all reflected transformations owned by this thread. */ @@ -615,8 +615,8 @@ TclChanPushObjCmd( methods = 0; while (listc > 0) { - if (Tcl_GetIndexFromObj(interp, listv[listc-1], methodNames, - "method", TCL_EXACT, &methIndex) != TCL_OK) { + if (Tcl_GetIndexFromObjStruct(interp, listv[listc-1], methodNames, + sizeof(char *), "method", TCL_EXACT, &methIndex) != TCL_OK) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "chan handler \"%s initialize\" returned %s", Tcl_GetString(cmdObj), @@ -943,7 +943,7 @@ ReflectClose( Tcl_EventuallyFree(rtPtr, (Tcl_FreeProc *) FreeReflectedTransform); return errorCode; - } + } #endif /* TCL_THREADS */ errorCodeSet = 1; goto cleanup; @@ -957,7 +957,7 @@ ReflectClose( Tcl_EventuallyFree(rtPtr, (Tcl_FreeProc *) FreeReflectedTransform); return errorCode; - } + } #endif /* TCL_THREADS */ errorCodeSet = 1; goto cleanup; @@ -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..f325a74 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -18,9 +18,6 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -#if defined(HAVE_SYS_STAT_H) && !defined _WIN32 -# include <sys/stat.h> -#endif #include "tclInt.h" #ifdef __WIN32__ # include "tclWinInt.h" @@ -54,7 +51,7 @@ typedef struct FilesystemRecord { * this information each time the corresponding epoch counter changes. */ -typedef struct ThreadSpecificData { +typedef struct { int initialized; int cwdPathEpoch; int filesystemEpoch; @@ -243,7 +240,7 @@ static Tcl_ThreadDataKey fsDataKey; * code. */ -typedef struct FsDivertLoad { +typedef struct { Tcl_LoadHandle loadHandle; Tcl_FSUnloadFileProc *unloadProcPtr; Tcl_Obj *divertedFile; @@ -2475,8 +2472,8 @@ TclFSFileAttrIndex( Tcl_Obj *tmpObj = Tcl_NewStringObj(attributeName, -1); int result; - result = Tcl_GetIndexFromObj(NULL, tmpObj, attrTable, NULL, TCL_EXACT, - indexPtr); + result = Tcl_GetIndexFromObjStruct(NULL, tmpObj, attrTable, + sizeof(char *), NULL, TCL_EXACT, indexPtr); TclDecrRefCount(tmpObj); if (listObj != NULL) { TclDecrRefCount(listObj); @@ -3360,7 +3357,7 @@ Tcl_LoadFile( return retVal; resolveSymbols: - /* + /* * At this point, *handlePtr is already set up to the handle for the * loaded library. We now try to resolve the symbols. */ @@ -3369,7 +3366,7 @@ Tcl_LoadFile( for (i=0 ; symbols[i] != NULL; i++) { procPtrs[i] = Tcl_FindSymbol(interp, *handlePtr, symbols[i]); if (procPtrs[i] == NULL) { - /* + /* * At least one symbol in the list was not found. Unload the * file, and report the problem back to the caller. * (Tcl_FindSymbol should already have left an appropriate @@ -3389,7 +3386,7 @@ Tcl_LoadFile( *---------------------------------------------------------------------- * * DivertFindSymbol -- - * + * * Find a symbol in a shared library loaded by copy-from-VFS. * *---------------------------------------------------------------------- diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index cb345e2..b80d649 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -53,7 +53,7 @@ static const Tcl_ObjType indexType = { /* * The definition of the internal representation of the "index" object; The - * internalRep.otherValuePtr field of an object of "index" type will be a + * internalRep.twoPtrValue.ptr1 field of an object of "index" type will be a * pointer to one of these structures. * * Keep this structure declaration in sync with tclTestObj.c @@ -69,74 +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) - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetIndexFromObj -- - * - * This function looks up an object's value in a table of strings and - * returns the index of the matching string, if any. - * - * Results: - * If the value of objPtr is identical to or a unique abbreviation for - * one of the entries in tablePtr, then the return value is TCL_OK and the - * index of the matching entry is stored at *indexPtr. If there isn't a - * proper match, then TCL_ERROR is returned and an error message is left - * in interp's result (unless interp is NULL). The msg argument is used - * in the error message; for example, if msg has the value "option" then - * the error message will say something flag 'bad option "foo": must be - * ...' - * - * Side effects: - * The result of the lookup is cached as the internal rep of objPtr, so - * that repeated lookups can be done quickly. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_GetIndexFromObj( - Tcl_Interp *interp, /* Used for error reporting if not NULL. */ - Tcl_Obj *objPtr, /* Object containing the string to lookup. */ - const char *const*tablePtr, /* Array of strings to compare against the - * value of objPtr; last entry must be NULL - * and there must not be duplicate entries. */ - const char *msg, /* Identifying word to use in error - * messages. */ - int flags, /* 0 or TCL_EXACT */ - int *indexPtr) /* Place to store resulting integer index. */ -{ - - /* - * See if there is a valid cached result from a previous lookup (doing the - * check here saves the overhead of calling Tcl_GetIndexFromObjStruct in - * the common case where the result is cached). - */ - - if (objPtr->typePtr == &indexType) { - IndexRep *indexRep = objPtr->internalRep.otherValuePtr; - - /* - * Here's hoping we don't get hit by unfortunate packing constraints - * on odd platforms like a Cray PVP... - */ - - if (indexRep->tablePtr == (void *) tablePtr - && indexRep->offset == sizeof(char *)) { - *indexPtr = indexRep->index; - return TCL_OK; - } - } - return Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, sizeof(char *), - msg, flags, indexPtr); -} + STRING_AT((indexRep)->tablePtr, (indexRep)->offset*(indexRep)->index) /* *---------------------------------------------------------------------- @@ -238,7 +176,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,12 +208,16 @@ 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. */ if (objPtr->typePtr == &indexType) { - indexRep = objPtr->internalRep.otherValuePtr; + indexRep = objPtr->internalRep.twoPtrValue.ptr1; if (indexRep->tablePtr==tablePtr && indexRep->offset==offset) { *indexPtr = indexRep->index; return TCL_OK; @@ -336,11 +278,11 @@ Tcl_GetIndexFromObjStruct( */ if (objPtr->typePtr == &indexType) { - indexRep = objPtr->internalRep.otherValuePtr; + indexRep = objPtr->internalRep.twoPtrValue.ptr1; } else { TclFreeIntRep(objPtr); indexRep = ckalloc(sizeof(IndexRep)); - objPtr->internalRep.otherValuePtr = indexRep; + objPtr->internalRep.twoPtrValue.ptr1 = indexRep; objPtr->typePtr = &indexType; } indexRep->tablePtr = (void *) tablePtr; @@ -443,7 +385,7 @@ static void UpdateStringOfIndex( Tcl_Obj *objPtr) { - IndexRep *indexRep = objPtr->internalRep.otherValuePtr; + IndexRep *indexRep = objPtr->internalRep.twoPtrValue.ptr1; register char *buf; register unsigned len; register const char *indexStr = EXPAND_OF(indexRep); @@ -478,11 +420,11 @@ DupIndex( Tcl_Obj *srcPtr, Tcl_Obj *dupPtr) { - IndexRep *srcIndexRep = srcPtr->internalRep.otherValuePtr; + IndexRep *srcIndexRep = srcPtr->internalRep.twoPtrValue.ptr1; IndexRep *dupIndexRep = ckalloc(sizeof(IndexRep)); memcpy(dupIndexRep, srcIndexRep, sizeof(IndexRep)); - dupPtr->internalRep.otherValuePtr = dupIndexRep; + dupPtr->internalRep.twoPtrValue.ptr1 = dupIndexRep; dupPtr->typePtr = &indexType; } @@ -507,7 +449,7 @@ static void FreeIndex( Tcl_Obj *objPtr) { - ckfree(objPtr->internalRep.otherValuePtr); + ckfree(objPtr->internalRep.twoPtrValue.ptr1); objPtr->typePtr = NULL; } @@ -533,9 +475,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; @@ -587,8 +529,8 @@ PrefixMatchObjCmd( } for (i = 1; i < (objc - 2); i++) { - if (Tcl_GetIndexFromObj(interp, objv[i], matchOptions, "option", 0, - &index) != TCL_OK) { + if (Tcl_GetIndexFromObjStruct(interp, objv[i], matchOptions, + sizeof(char *), "option", 0, &index) != TCL_OK) { return TCL_ERROR; } switch ((enum matchOptions) index) { @@ -657,7 +599,7 @@ PrefixMatchObjCmd( } Tcl_ListObjAppendElement(interp, errorPtr, Tcl_NewStringObj("-code", 5)); - Tcl_ListObjAppendElement(interp, errorPtr, Tcl_NewIntObj(result)); + Tcl_ListObjAppendElement(interp, errorPtr, Tcl_NewLongObj(result)); return Tcl_SetReturnOptions(interp, errorPtr); } @@ -873,7 +815,8 @@ Tcl_WrongNumArgs( * NULL. */ { Tcl_Obj *objPtr; - int i, len, elemLen, flags; + int i, len, elemLen; + char flags; Interp *iPtr = (Interp *) interp; const char *elementStr; @@ -948,13 +891,13 @@ Tcl_WrongNumArgs( if (origObjv[i]->typePtr == &indexType) { register IndexRep *indexRep = - origObjv[i]->internalRep.otherValuePtr; + origObjv[i]->internalRep.twoPtrValue.ptr1; elementStr = EXPAND_OF(indexRep); elemLen = strlen(elementStr); } else if (origObjv[i]->typePtr == &tclEnsembleCmdType) { register EnsembleCmdRep *ecrPtr = - origObjv[i]->internalRep.otherValuePtr; + origObjv[i]->internalRep.twoPtrValue.ptr1; elementStr = ecrPtr->fullSubcmdName; elemLen = strlen(elementStr); @@ -1003,12 +946,12 @@ Tcl_WrongNumArgs( */ if (objv[i]->typePtr == &indexType) { - register IndexRep *indexRep = objv[i]->internalRep.otherValuePtr; + register IndexRep *indexRep = objv[i]->internalRep.twoPtrValue.ptr1; Tcl_AppendStringsToObj(objPtr, EXPAND_OF(indexRep), NULL); } else if (objv[i]->typePtr == &tclEnsembleCmdType) { register EnsembleCmdRep *ecrPtr = - objv[i]->internalRep.otherValuePtr; + objv[i]->internalRep.twoPtrValue.ptr1; Tcl_AppendStringsToObj(objPtr, ecrPtr->fullSubcmdName, NULL); } else { @@ -1459,8 +1402,8 @@ TclGetCompletionCodeFromObj( && TclGetIntFromObj(NULL, value, codePtr) == TCL_OK) { return TCL_OK; } - if (Tcl_GetIndexFromObj(NULL, value, returnCodes, NULL, TCL_EXACT, - codePtr) == TCL_OK) { + if (Tcl_GetIndexFromObjStruct(NULL, value, returnCodes, + sizeof(char *), NULL, TCL_EXACT, codePtr) == TCL_OK) { return TCL_OK; } diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 8c46e55..b840d04 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -457,29 +457,35 @@ declare 111 { Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc) } -declare 112 { - int Tcl_AppendExportList(Tcl_Interp *interp, Tcl_Namespace *nsPtr, - Tcl_Obj *objPtr) -} -declare 113 { - Tcl_Namespace *Tcl_CreateNamespace(Tcl_Interp *interp, const char *name, - ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc) -} -declare 114 { - void Tcl_DeleteNamespace(Tcl_Namespace *nsPtr) -} -declare 115 { - int Tcl_Export(Tcl_Interp *interp, Tcl_Namespace *nsPtr, - const char *pattern, int resetListFirst) -} -declare 116 { - Tcl_Command Tcl_FindCommand(Tcl_Interp *interp, const char *name, - Tcl_Namespace *contextNsPtr, int flags) -} -declare 117 { - Tcl_Namespace *Tcl_FindNamespace(Tcl_Interp *interp, const char *name, - Tcl_Namespace *contextNsPtr, int flags) -} +# Removed in 9.0: +#declare 112 { +# int Tcl_AppendExportList(Tcl_Interp *interp, Tcl_Namespace *nsPtr, +# Tcl_Obj *objPtr) +#} +# Removed in 9.0: +#declare 113 { +# Tcl_Namespace *Tcl_CreateNamespace(Tcl_Interp *interp, const char *name, +# ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc) +#} +# Removed in 9.0: +#declare 114 { +# void Tcl_DeleteNamespace(Tcl_Namespace *nsPtr) +#} +# Removed in 9.0: +#declare 115 { +# int Tcl_Export(Tcl_Interp *interp, Tcl_Namespace *nsPtr, +# const char *pattern, int resetListFirst) +#} +# Removed in 9.0: +#declare 116 { +# Tcl_Command Tcl_FindCommand(Tcl_Interp *interp, const char *name, +# Tcl_Namespace *contextNsPtr, int flags) +#} +# Removed in 9.0: +#declare 117 { +# Tcl_Namespace *Tcl_FindNamespace(Tcl_Interp *interp, const char *name, +# Tcl_Namespace *contextNsPtr, int flags) +#} declare 118 { int Tcl_GetInterpResolvers(Tcl_Interp *interp, const char *name, Tcl_ResolverInfo *resInfo) @@ -492,31 +498,37 @@ declare 120 { Tcl_Var Tcl_FindNamespaceVar(Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags) } -declare 121 { - int Tcl_ForgetImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, - const char *pattern) -} -declare 122 { - Tcl_Command Tcl_GetCommandFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr) -} -declare 123 { - void Tcl_GetCommandFullName(Tcl_Interp *interp, Tcl_Command command, - Tcl_Obj *objPtr) -} -declare 124 { - Tcl_Namespace *Tcl_GetCurrentNamespace(Tcl_Interp *interp) -} -declare 125 { - Tcl_Namespace *Tcl_GetGlobalNamespace(Tcl_Interp *interp) -} +# Removed in 9.0: +#declare 121 { +# int Tcl_ForgetImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, +# const char *pattern) +#} +# Removed in 9.0: +#declare 122 { +# Tcl_Command Tcl_GetCommandFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr) +#} +# Removed in 9.0: +#declare 123 { +# void Tcl_GetCommandFullName(Tcl_Interp *interp, Tcl_Command command, +# Tcl_Obj *objPtr) +#} +# Removed in 9.0: +#declare 124 { +# Tcl_Namespace *Tcl_GetCurrentNamespace(Tcl_Interp *interp) +#} +# Removed in 9.0: +#declare 125 { +# Tcl_Namespace *Tcl_GetGlobalNamespace(Tcl_Interp *interp) +#} declare 126 { void Tcl_GetVariableFullName(Tcl_Interp *interp, Tcl_Var variable, Tcl_Obj *objPtr) } -declare 127 { - int Tcl_Import(Tcl_Interp *interp, Tcl_Namespace *nsPtr, - const char *pattern, int allowOverwrite) -} +# Removed in 9.0: +#declare 127 { +# int Tcl_Import(Tcl_Interp *interp, Tcl_Namespace *nsPtr, +# const char *pattern, int allowOverwrite) +#} declare 128 { void Tcl_PopCallFrame(Tcl_Interp *interp) } @@ -1046,9 +1058,10 @@ declare 5 win { # declare 5 win { # HINSTANCE TclWinLoadLibrary(char *name) # } -declare 6 win { - unsigned short TclWinNToHS(unsigned short ns) -} +# Removed in 8.1: +#declare 6 win { +# unsigned short TclWinNToHS(unsigned short ns) +#} declare 7 win { int TclWinSetSockOpt(SOCKET s, int level, int optname, const char *optval, int optlen) diff --git a/generic/tclInt.h b/generic/tclInt.h index 8a78b94..343d1c4 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -397,7 +397,7 @@ struct NamespacePathEntry { /* * The data cached in an ensemble subcommand's Tcl_Obj rep (reference in - * otherValuePtr field). This structure is not shared between Tcl_Objs + * twoPtrValue.ptr1 field). This structure is not shared between Tcl_Objs * referring to the same subcommand, even where one is a duplicate of another. */ @@ -590,30 +590,6 @@ typedef struct ActiveVarTrace { } ActiveVarTrace; /* - * The following structure describes an enumerative search in progress on an - * array variable; this are invoked with options to the "array" command. - */ - -typedef struct ArraySearch { - int id; /* Integer id used to distinguish among - * multiple concurrent searches for the same - * array. */ - struct Var *varPtr; /* Pointer to array variable that's being - * searched. */ - Tcl_HashSearch search; /* Info kept by the hash module about progress - * through the array. */ - Tcl_HashEntry *nextEntry; /* Non-null means this is the next element to - * be enumerated (it's leftover from the - * Tcl_FirstHashEntry call or from an "array - * anymore" command). NULL means must call - * Tcl_NextHashEntry to get value to - * return. */ - struct ArraySearch *nextPtr;/* Next in list of all active searches for - * this variable, or NULL if this is the last - * one. */ -} ArraySearch; - -/* * The structure below defines a variable, which associates a string name with * a Tcl_Obj value. These structures are kept in procedure call frames (for * local variables recognized by the compiler) or in the heap (for global @@ -1155,7 +1131,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; @@ -2176,17 +2152,6 @@ typedef struct Interp { (iPtr)->flags &= (~(CANCELED | TCL_CANCEL_UNWIND)) /* - * General list of interpreters. Doubly linked for easier removal of items - * deep in the list. - */ - -typedef struct InterpList { - Interp *interpPtr; - struct InterpList *prevPtr; - struct InterpList *nextPtr; -} InterpList; - -/* * Macros for splicing into and out of doubly linked lists. They assume * existence of struct items 'prevPtr' and 'nextPtr'. * @@ -2224,7 +2189,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: @@ -2292,35 +2256,6 @@ typedef struct InterpList { #define MAX_NESTING_DEPTH 1000 /* - * TIP#143 limit handler internal representation. - */ - -struct LimitHandler { - int flags; /* The state of this particular handler. */ - Tcl_LimitHandlerProc *handlerProc; - /* The handler callback. */ - ClientData clientData; /* Opaque argument to the handler callback. */ - Tcl_LimitHandlerDeleteProc *deleteProc; - /* How to delete the clientData. */ - LimitHandler *prevPtr; /* Previous item in linked list of - * handlers. */ - LimitHandler *nextPtr; /* Next item in linked list of handlers. */ -}; - -/* - * Values for the LimitHandler flags field. - * LIMIT_HANDLER_ACTIVE - Whether the handler is currently being - * processed; handlers are never to be entered reentrantly. - * LIMIT_HANDLER_DELETED - Whether the handler has been deleted. This - * should not normally be observed because when a handler is - * deleted it is also spliced out of the list of handlers, but - * even so we will be careful. - */ - -#define LIMIT_HANDLER_ACTIVE 0x01 -#define LIMIT_HANDLER_DELETED 0x02 - -/* * The macro below is used to modify a "char" value (e.g. by casting it to an * unsigned character) so that it can be used safely with macros such as * isspace. @@ -2769,8 +2704,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 +2784,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, @@ -2881,7 +2819,7 @@ MODULE_SCOPE ContLineLoc *TclContinuationsGet(Tcl_Obj *objPtr); MODULE_SCOPE void TclContinuationsCopy(Tcl_Obj *objPtr, Tcl_Obj *originObjPtr); MODULE_SCOPE int TclConvertElement(const char *src, int length, - char *dst, int flags); + char *dst, char flags); MODULE_SCOPE void TclDeleteNamespaceVars(Namespace *nsPtr); /* TIP #280 - Modified token based evulation, with line information. */ MODULE_SCOPE int TclEvalEx(Tcl_Interp *interp, const char *script, @@ -3086,11 +3024,12 @@ MODULE_SCOPE void TclRemoveScriptLimitCallbacks(Tcl_Interp *interp); MODULE_SCOPE int TclReToGlob(Tcl_Interp *interp, const char *reStr, int reStrLen, Tcl_DString *dsPtr, int *flagsPtr); MODULE_SCOPE int TclScanElement(const char *string, int length, - int *flagPtr); + char *flagPtr); MODULE_SCOPE void TclSetBgErrorHandler(Tcl_Interp *interp, Tcl_Obj *cmdPrefix); MODULE_SCOPE void TclSetBignumIntRep(Tcl_Obj *objPtr, mp_int *bignumValue); +MODULE_SCOPE int TclSetBooleanFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); MODULE_SCOPE void TclSetCmdNameObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Command *cmdPtr); MODULE_SCOPE void TclSetDuplicateObj(Tcl_Obj *dupPtr, Tcl_Obj *objPtr); @@ -3672,6 +3611,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, @@ -3973,12 +3948,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) /* @@ -4014,7 +3990,7 @@ MODULE_SCOPE void TclpFreeAllocCache(void *); (objPtr) = TclThreadAllocObj(); \ } else { \ (objPtr) = cachePtr->firstObjPtr; \ - cachePtr->firstObjPtr = (objPtr)->internalRep.otherValuePtr; \ + cachePtr->firstObjPtr = (objPtr)->internalRep.twoPtrValue.ptr1; \ --cachePtr->numObjects; \ } \ } while (0) @@ -4027,7 +4003,7 @@ MODULE_SCOPE void TclpFreeAllocCache(void *); (cachePtr->numObjects >= ALLOC_NOBJHIGH))) { \ TclThreadFreeObj(objPtr); \ } else { \ - (objPtr)->internalRep.otherValuePtr = cachePtr->firstObjPtr; \ + (objPtr)->internalRep.twoPtrValue.ptr1 = cachePtr->firstObjPtr; \ cachePtr->firstObjPtr = objPtr; \ ++cachePtr->numObjects; \ } \ @@ -4055,14 +4031,14 @@ MODULE_SCOPE Tcl_Mutex tclObjMutex; } \ (objPtr) = tclFreeObjList; \ tclFreeObjList = (Tcl_Obj *) \ - tclFreeObjList->internalRep.otherValuePtr; \ + tclFreeObjList->internalRep.twoPtrValue.ptr1; \ Tcl_MutexUnlock(&tclObjMutex); \ } while (0) # define TclFreeObjStorageEx(interp, objPtr) \ do { \ Tcl_MutexLock(&tclObjMutex); \ - (objPtr)->internalRep.otherValuePtr = (void *) tclFreeObjList; \ + (objPtr)->internalRep.twoPtrValue.ptr1 = (void *) tclFreeObjList; \ tclFreeObjList = (objPtr); \ Tcl_MutexUnlock(&tclObjMutex); \ } while (0) @@ -4389,15 +4365,13 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; * core. They should only be called on unshared objects. The ANSI C * "prototypes" for these macros are: * - * MODULE_SCOPE void TclSetIntObj(Tcl_Obj *objPtr, int intValue); * MODULE_SCOPE void TclSetLongObj(Tcl_Obj *objPtr, long longValue); - * MODULE_SCOPE void TclSetBooleanObj(Tcl_Obj *objPtr, long boolValue); * MODULE_SCOPE void TclSetWideIntObj(Tcl_Obj *objPtr, Tcl_WideInt w); * MODULE_SCOPE void TclSetDoubleObj(Tcl_Obj *objPtr, double d); *---------------------------------------------------------------- */ -#define TclSetIntObj(objPtr, i) \ +#define TclSetLongObj(objPtr, i) \ do { \ TclInvalidateStringRep(objPtr); \ TclFreeIntRep(objPtr); \ @@ -4405,9 +4379,6 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; (objPtr)->typePtr = &tclIntType; \ } while (0) -#define TclSetLongObj(objPtr, l) \ - TclSetIntObj((objPtr), (l)) - /* * NOTE: There is to be no such thing as a "pure" boolean. Boolean values set * programmatically go straight to being "int" Tcl_Obj's, with value 0 or 1. @@ -4415,9 +4386,6 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; * value of strings like: "yes", "no", "true", "false", "on", "off". */ -#define TclSetBooleanObj(objPtr, b) \ - TclSetIntObj((objPtr), ((b)? 1 : 0)); - #ifndef NO_WIDE_TYPE #define TclSetWideIntObj(objPtr, w) \ do { \ @@ -4442,9 +4410,7 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; * types, avoiding the corresponding function calls in time critical parts of * the core. The ANSI C "prototypes" for these macros are: * - * MODULE_SCOPE void TclNewIntObj(Tcl_Obj *objPtr, int i); * MODULE_SCOPE void TclNewLongObj(Tcl_Obj *objPtr, long l); - * MODULE_SCOPE void TclNewBooleanObj(Tcl_Obj *objPtr, int b); * MODULE_SCOPE void TclNewWideObj(Tcl_Obj *objPtr, Tcl_WideInt w); * MODULE_SCOPE void TclNewDoubleObj(Tcl_Obj *objPtr, double d); * MODULE_SCOPE void TclNewStringObj(Tcl_Obj *objPtr, char *s, int len); @@ -4454,7 +4420,7 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; */ #ifndef TCL_MEM_DEBUG -#define TclNewIntObj(objPtr, i) \ +#define TclNewLongObj(objPtr, i) \ do { \ TclIncrObjsAllocated(); \ TclAllocObjStorage(objPtr); \ @@ -4465,16 +4431,6 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; TCL_DTRACE_OBJ_CREATE(objPtr); \ } while (0) -#define TclNewLongObj(objPtr, l) \ - TclNewIntObj((objPtr), (l)) - -/* - * NOTE: There is to be no such thing as a "pure" boolean. - * See comment above TclSetBooleanObj macro above. - */ -#define TclNewBooleanObj(objPtr, b) \ - TclNewIntObj((objPtr), ((b)? 1 : 0)) - #define TclNewDoubleObj(objPtr, d) \ do { \ TclIncrObjsAllocated(); \ @@ -4497,15 +4453,9 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; } while (0) #else /* TCL_MEM_DEBUG */ -#define TclNewIntObj(objPtr, i) \ - (objPtr) = Tcl_NewIntObj(i) - #define TclNewLongObj(objPtr, l) \ (objPtr) = Tcl_NewLongObj(l) -#define TclNewBooleanObj(objPtr, b) \ - (objPtr) = Tcl_NewBooleanObj(b) - #define TclNewDoubleObj(objPtr, d) \ (objPtr) = Tcl_NewDoubleObj(d) @@ -4736,35 +4686,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..26b168f 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -17,21 +17,6 @@ #include "tclPort.h" -/* [Bug #803489] Tcl_FindNamespace problem in the Stubs table */ -#undef Tcl_AppendExportList -#undef Tcl_CreateNamespace -#undef Tcl_DeleteNamespace -#undef Tcl_Export -#undef Tcl_FindCommand -#undef Tcl_FindNamespace -#undef Tcl_FindNamespaceVar -#undef Tcl_ForgetImport -#undef Tcl_GetCommandFromObj -#undef Tcl_GetCommandFullName -#undef Tcl_GetCurrentNamespace -#undef Tcl_GetGlobalNamespace -#undef Tcl_Import - /* * WARNING: This file is automatically generated by the tools/genStubs.tcl * script. Any modifications to the function declarations below should be made @@ -262,25 +247,12 @@ TCLAPI void Tcl_AddInterpResolvers(Tcl_Interp *interp, Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); -/* 112 */ -TCLAPI int Tcl_AppendExportList(Tcl_Interp *interp, - Tcl_Namespace *nsPtr, Tcl_Obj *objPtr); -/* 113 */ -TCLAPI Tcl_Namespace * Tcl_CreateNamespace(Tcl_Interp *interp, - const char *name, ClientData clientData, - Tcl_NamespaceDeleteProc *deleteProc); -/* 114 */ -TCLAPI void Tcl_DeleteNamespace(Tcl_Namespace *nsPtr); -/* 115 */ -TCLAPI int Tcl_Export(Tcl_Interp *interp, Tcl_Namespace *nsPtr, - const char *pattern, int resetListFirst); -/* 116 */ -TCLAPI Tcl_Command Tcl_FindCommand(Tcl_Interp *interp, const char *name, - Tcl_Namespace *contextNsPtr, int flags); -/* 117 */ -TCLAPI Tcl_Namespace * Tcl_FindNamespace(Tcl_Interp *interp, - const char *name, - Tcl_Namespace *contextNsPtr, int flags); +/* Slot 112 is reserved */ +/* Slot 113 is reserved */ +/* Slot 114 is reserved */ +/* Slot 115 is reserved */ +/* Slot 116 is reserved */ +/* Slot 117 is reserved */ /* 118 */ TCLAPI int Tcl_GetInterpResolvers(Tcl_Interp *interp, const char *name, Tcl_ResolverInfo *resInfo); @@ -292,25 +264,15 @@ TCLAPI int Tcl_GetNamespaceResolvers( TCLAPI Tcl_Var Tcl_FindNamespaceVar(Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); -/* 121 */ -TCLAPI int Tcl_ForgetImport(Tcl_Interp *interp, - Tcl_Namespace *nsPtr, const char *pattern); -/* 122 */ -TCLAPI Tcl_Command Tcl_GetCommandFromObj(Tcl_Interp *interp, - Tcl_Obj *objPtr); -/* 123 */ -TCLAPI void Tcl_GetCommandFullName(Tcl_Interp *interp, - Tcl_Command command, Tcl_Obj *objPtr); -/* 124 */ -TCLAPI Tcl_Namespace * Tcl_GetCurrentNamespace(Tcl_Interp *interp); -/* 125 */ -TCLAPI Tcl_Namespace * Tcl_GetGlobalNamespace(Tcl_Interp *interp); +/* Slot 121 is reserved */ +/* Slot 122 is reserved */ +/* Slot 123 is reserved */ +/* Slot 124 is reserved */ +/* Slot 125 is reserved */ /* 126 */ TCLAPI void Tcl_GetVariableFullName(Tcl_Interp *interp, Tcl_Var variable, Tcl_Obj *objPtr); -/* 127 */ -TCLAPI int Tcl_Import(Tcl_Interp *interp, Tcl_Namespace *nsPtr, - const char *pattern, int allowOverwrite); +/* Slot 127 is reserved */ /* 128 */ TCLAPI void Tcl_PopCallFrame(Tcl_Interp *interp); /* 129 */ @@ -697,22 +659,22 @@ typedef struct TclIntStubs { int (*tclUpdateReturnInfo) (Interp *iPtr); /* 109 */ int (*tclSockMinimumBuffers) (void *sock, int size); /* 110 */ void (*tcl_AddInterpResolvers) (Tcl_Interp *interp, const char *name, Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); /* 111 */ - int (*tcl_AppendExportList) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *objPtr); /* 112 */ - Tcl_Namespace * (*tcl_CreateNamespace) (Tcl_Interp *interp, const char *name, ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc); /* 113 */ - void (*tcl_DeleteNamespace) (Tcl_Namespace *nsPtr); /* 114 */ - int (*tcl_Export) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int resetListFirst); /* 115 */ - Tcl_Command (*tcl_FindCommand) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 116 */ - Tcl_Namespace * (*tcl_FindNamespace) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 117 */ + void (*reserved112)(void); + void (*reserved113)(void); + void (*reserved114)(void); + void (*reserved115)(void); + void (*reserved116)(void); + void (*reserved117)(void); int (*tcl_GetInterpResolvers) (Tcl_Interp *interp, const char *name, Tcl_ResolverInfo *resInfo); /* 118 */ int (*tcl_GetNamespaceResolvers) (Tcl_Namespace *namespacePtr, Tcl_ResolverInfo *resInfo); /* 119 */ Tcl_Var (*tcl_FindNamespaceVar) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 120 */ - int (*tcl_ForgetImport) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern); /* 121 */ - Tcl_Command (*tcl_GetCommandFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 122 */ - void (*tcl_GetCommandFullName) (Tcl_Interp *interp, Tcl_Command command, Tcl_Obj *objPtr); /* 123 */ - Tcl_Namespace * (*tcl_GetCurrentNamespace) (Tcl_Interp *interp); /* 124 */ - Tcl_Namespace * (*tcl_GetGlobalNamespace) (Tcl_Interp *interp); /* 125 */ + void (*reserved121)(void); + void (*reserved122)(void); + void (*reserved123)(void); + void (*reserved124)(void); + void (*reserved125)(void); void (*tcl_GetVariableFullName) (Tcl_Interp *interp, Tcl_Var variable, Tcl_Obj *objPtr); /* 126 */ - int (*tcl_Import) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int allowOverwrite); /* 127 */ + void (*reserved127)(void); void (*tcl_PopCallFrame) (Tcl_Interp *interp); /* 128 */ int (*tcl_PushCallFrame) (Tcl_Interp *interp, Tcl_CallFrame *framePtr, Tcl_Namespace *nsPtr, int isProcCallFrame); /* 129 */ int (*tcl_RemoveInterpResolvers) (Tcl_Interp *interp, const char *name); /* 130 */ @@ -1022,38 +984,26 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclSockMinimumBuffers) /* 110 */ #define Tcl_AddInterpResolvers \ (tclIntStubsPtr->tcl_AddInterpResolvers) /* 111 */ -#define Tcl_AppendExportList \ - (tclIntStubsPtr->tcl_AppendExportList) /* 112 */ -#define Tcl_CreateNamespace \ - (tclIntStubsPtr->tcl_CreateNamespace) /* 113 */ -#define Tcl_DeleteNamespace \ - (tclIntStubsPtr->tcl_DeleteNamespace) /* 114 */ -#define Tcl_Export \ - (tclIntStubsPtr->tcl_Export) /* 115 */ -#define Tcl_FindCommand \ - (tclIntStubsPtr->tcl_FindCommand) /* 116 */ -#define Tcl_FindNamespace \ - (tclIntStubsPtr->tcl_FindNamespace) /* 117 */ +/* Slot 112 is reserved */ +/* Slot 113 is reserved */ +/* Slot 114 is reserved */ +/* Slot 115 is reserved */ +/* Slot 116 is reserved */ +/* Slot 117 is reserved */ #define Tcl_GetInterpResolvers \ (tclIntStubsPtr->tcl_GetInterpResolvers) /* 118 */ #define Tcl_GetNamespaceResolvers \ (tclIntStubsPtr->tcl_GetNamespaceResolvers) /* 119 */ #define Tcl_FindNamespaceVar \ (tclIntStubsPtr->tcl_FindNamespaceVar) /* 120 */ -#define Tcl_ForgetImport \ - (tclIntStubsPtr->tcl_ForgetImport) /* 121 */ -#define Tcl_GetCommandFromObj \ - (tclIntStubsPtr->tcl_GetCommandFromObj) /* 122 */ -#define Tcl_GetCommandFullName \ - (tclIntStubsPtr->tcl_GetCommandFullName) /* 123 */ -#define Tcl_GetCurrentNamespace \ - (tclIntStubsPtr->tcl_GetCurrentNamespace) /* 124 */ -#define Tcl_GetGlobalNamespace \ - (tclIntStubsPtr->tcl_GetGlobalNamespace) /* 125 */ +/* Slot 121 is reserved */ +/* Slot 122 is reserved */ +/* Slot 123 is reserved */ +/* Slot 124 is reserved */ +/* Slot 125 is reserved */ #define Tcl_GetVariableFullName \ (tclIntStubsPtr->tcl_GetVariableFullName) /* 126 */ -#define Tcl_Import \ - (tclIntStubsPtr->tcl_Import) /* 127 */ +/* Slot 127 is reserved */ #define Tcl_PopCallFrame \ (tclIntStubsPtr->tcl_PopCallFrame) /* 128 */ #define Tcl_PushCallFrame \ diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h index f7eb442..010fe88 100644 --- a/generic/tclIntPlatDecls.h +++ b/generic/tclIntPlatDecls.h @@ -101,8 +101,7 @@ TCLAPI int TclWinGetSockOpt(SOCKET s, int level, int optname, TCLAPI HINSTANCE TclWinGetTclInstance(void); /* 5 */ TCLAPI int TclUnixWaitForFile(int fd, int mask, int timeout); -/* 6 */ -TCLAPI unsigned short TclWinNToHS(unsigned short ns); +/* Slot 6 is reserved */ /* 7 */ TCLAPI int TclWinSetSockOpt(SOCKET s, int level, int optname, const char *optval, int optlen); @@ -278,7 +277,7 @@ typedef struct TclIntPlatStubs { int (*tclWinGetSockOpt) (SOCKET s, int level, int optname, char *optval, int *optlen); /* 3 */ HINSTANCE (*tclWinGetTclInstance) (void); /* 4 */ int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 5 */ - unsigned short (*tclWinNToHS) (unsigned short ns); /* 6 */ + void (*reserved6)(void); int (*tclWinSetSockOpt) (SOCKET s, int level, int optname, const char *optval, int optlen); /* 7 */ int (*tclpGetPid) (Tcl_Pid pid); /* 8 */ int (*tclWinGetPlatformId) (void); /* 9 */ @@ -412,8 +411,7 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; (tclIntPlatStubsPtr->tclWinGetTclInstance) /* 4 */ #define TclUnixWaitForFile \ (tclIntPlatStubsPtr->tclUnixWaitForFile) /* 5 */ -#define TclWinNToHS \ - (tclIntPlatStubsPtr->tclWinNToHS) /* 6 */ +/* Slot 6 is reserved */ #define TclWinSetSockOpt \ (tclIntPlatStubsPtr->tclWinSetSockOpt) /* 7 */ #define TclpGetPid \ @@ -518,10 +516,7 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; /* !END!: Do not edit above this line. */ -#if defined(__WIN32__) || defined(__CYGWIN__) -# undef TclWinNToHS -# define TclWinNToHS ntohs -#else +#if !defined(__WIN32__) && !defined(__CYGWIN__) # undef TclpGetPid # define TclpGetPid(pid) ((unsigned long) (pid)) #endif diff --git a/generic/tclInterp.c b/generic/tclInterp.c index 0b0f652..241d428 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -25,14 +25,14 @@ static const char *tclPreInitScript = NULL; struct Target; /* - * struct Alias: + * Alias: * * Stores information about an alias. Is stored in the slave interpreter and * used by the source command to find the target command in the master when * the source command is invoked. */ -typedef struct Alias { +typedef struct { Tcl_Obj *token; /* Token for the alias command in the slave * interp. This used to be the command name in * the slave when the alias was first @@ -73,7 +73,7 @@ typedef struct Alias { * slave interpreter, e.g. what aliases are defined in it. */ -typedef struct Slave { +typedef struct { Tcl_Interp *masterInterp; /* Master interpreter for this slave. */ Tcl_HashEntry *slaveEntryPtr; /* Hash entry in masters slave table for this @@ -84,7 +84,7 @@ typedef struct Slave { Tcl_Interp *slaveInterp; /* The slave interpreter. */ Tcl_Command interpCmd; /* Interpreter object command. */ Tcl_HashTable aliasTable; /* Table which maps from names of commands in - * slave interpreter to struct Alias defined + * slave interpreter to Alias defined * below. */ } Slave; @@ -127,7 +127,7 @@ typedef struct Target { * only load safe extensions. */ -typedef struct Master { +typedef struct { Tcl_HashTable slaveTable; /* Hash table for slave interpreters. Maps * from command names to Slave records. */ Target *targetsPtr; /* The head of a doubly-linked list of all the @@ -144,7 +144,7 @@ typedef struct Master { * on a per-interp basis. */ -typedef struct InterpInfo { +typedef struct { Master master; /* Keeps track of all interps for which this * interp is the Master. */ Slave slave; /* Information necessary for this interp to @@ -158,7 +158,7 @@ typedef struct InterpInfo { * likely to work properly on 64-bit architectures. */ -typedef struct ScriptLimitCallback { +typedef struct { Tcl_Interp *interp; /* The interpreter in which to execute the * callback. */ Tcl_Obj *scriptObj; /* The script to execute to perform the @@ -171,7 +171,7 @@ typedef struct ScriptLimitCallback { * table. */ } ScriptLimitCallback; -typedef struct ScriptLimitCallbackKey { +typedef struct { Tcl_Interp *interp; /* The interpreter that the limit callback was * attached to. This is not the interpreter * that the callback runs in! */ @@ -179,6 +179,37 @@ typedef struct ScriptLimitCallbackKey { } ScriptLimitCallbackKey; /* + * TIP#143 limit handler internal representation. + */ + +struct LimitHandler { + int flags; /* The state of this particular handler. */ + Tcl_LimitHandlerProc *handlerProc; + /* The handler callback. */ + ClientData clientData; /* Opaque argument to the handler callback. */ + Tcl_LimitHandlerDeleteProc *deleteProc; + /* How to delete the clientData. */ + LimitHandler *prevPtr; /* Previous item in linked list of + * handlers. */ + LimitHandler *nextPtr; /* Next item in linked list of handlers. */ +}; + +/* + * Values for the LimitHandler flags field. + * LIMIT_HANDLER_ACTIVE - Whether the handler is currently being + * processed; handlers are never to be entered reentrantly. + * LIMIT_HANDLER_DELETED - Whether the handler has been deleted. This + * should not normally be observed because when a handler is + * deleted it is also spliced out of the list of handlers, but + * even so we will be careful. + */ + +#define LIMIT_HANDLER_ACTIVE 0x01 +#define LIMIT_HANDLER_DELETED 0x02 + + + +/* * Prototypes for local static functions: */ @@ -299,7 +330,7 @@ Tcl_Init( Tcl_Interp *interp) /* Interpreter to initialize. */ { if (tclPreInitScript != NULL) { - if (Tcl_Eval(interp, tclPreInitScript) == TCL_ERROR) { + if (Tcl_EvalEx(interp, tclPreInitScript, -1, 0) == TCL_ERROR) { return TCL_ERROR; } } @@ -345,7 +376,7 @@ Tcl_Init( * alternate tclInit command before calling Tcl_Init(). */ - return Tcl_Eval(interp, + return Tcl_EvalEx(interp, "if {[namespace which -command tclInit] eq \"\"} {\n" " proc tclInit {} {\n" " global tcl_libPath tcl_library env tclDefaultLibrary\n" @@ -407,7 +438,7 @@ Tcl_Init( " error $msg\n" " }\n" "}\n" -"tclInit"); +"tclInit", -1, 0); } /* @@ -1798,9 +1829,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); } @@ -3141,8 +3172,8 @@ Tcl_MakeSafe( * Assume these functions all work. [Bug 2895741] */ - (void) Tcl_Eval(interp, - "namespace eval ::tcl {namespace eval mathfunc {}}"); + (void) Tcl_EvalEx(interp, + "namespace eval ::tcl {namespace eval mathfunc {}}", -1, 0); (void) Tcl_CreateAlias(interp, "::tcl::mathfunc::min", master, "::tcl::mathfunc::min", 0, NULL); (void) Tcl_CreateAlias(interp, "::tcl::mathfunc::max", master, diff --git a/generic/tclLink.c b/generic/tclLink.c index a3b42bd..1d1ed21 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -21,7 +21,7 @@ * variable. */ -typedef struct Link { +typedef struct { Tcl_Interp *interp; /* Interpreter containing Tcl variable. */ Tcl_Obj *varName; /* Name of variable (must be global). This is * needed during trace callbacks, since the @@ -112,8 +112,8 @@ Tcl_LinkVar( Link *linkPtr; int code; - linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, TCL_GLOBAL_ONLY, - LinkTraceProc, (ClientData) NULL); + linkPtr = (Link *) Tcl_VarTraceInfo2(interp, varName, NULL, + TCL_GLOBAL_ONLY, LinkTraceProc, (ClientData) NULL); if (linkPtr != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "variable '%s' is already linked", varName)); @@ -138,8 +138,9 @@ Tcl_LinkVar( ckfree(linkPtr); return TCL_ERROR; } - code = Tcl_TraceVar(interp, varName, TCL_GLOBAL_ONLY|TCL_TRACE_READS - |TCL_TRACE_WRITES|TCL_TRACE_UNSETS, LinkTraceProc, linkPtr); + code = Tcl_TraceVar2(interp, varName, NULL, + TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + LinkTraceProc, linkPtr); if (code != TCL_OK) { Tcl_DecrRefCount(linkPtr->varName); ckfree(linkPtr); @@ -170,13 +171,13 @@ Tcl_UnlinkVar( Tcl_Interp *interp, /* Interpreter containing variable to unlink */ const char *varName) /* Global variable in interp to unlink. */ { - Link *linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, + Link *linkPtr = (Link *) Tcl_VarTraceInfo2(interp, varName, NULL, TCL_GLOBAL_ONLY, LinkTraceProc, NULL); if (linkPtr == NULL) { return; } - Tcl_UntraceVar(interp, varName, + Tcl_UntraceVar2(interp, varName, NULL, TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, LinkTraceProc, linkPtr); Tcl_DecrRefCount(linkPtr->varName); @@ -207,7 +208,7 @@ Tcl_UpdateLinkedVar( Tcl_Interp *interp, /* Interpreter containing variable. */ const char *varName) /* Name of global variable that is linked. */ { - Link *linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, + Link *linkPtr = (Link *) Tcl_VarTraceInfo2(interp, varName, NULL, TCL_GLOBAL_ONLY, LinkTraceProc, NULL); int savedFlag; @@ -221,8 +222,8 @@ Tcl_UpdateLinkedVar( /* * Callback may have unlinked the variable. [Bug 1740631] */ - linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, TCL_GLOBAL_ONLY, - LinkTraceProc, NULL); + linkPtr = (Link *) Tcl_VarTraceInfo2(interp, varName, NULL, + TCL_GLOBAL_ONLY, LinkTraceProc, NULL); if (linkPtr != NULL) { linkPtr->flags = (linkPtr->flags & ~LINK_BEING_UPDATED) | savedFlag; } @@ -278,7 +279,7 @@ LinkTraceProc( } else if (flags & TCL_TRACE_DESTROYED) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); - Tcl_TraceVar(interp, Tcl_GetString(linkPtr->varName), + Tcl_TraceVar2(interp, Tcl_GetString(linkPtr->varName), NULL, TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES |TCL_TRACE_UNSETS, LinkTraceProc, linkPtr); } diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 3668b45..f5123e8 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -237,7 +237,7 @@ Tcl_NewListObj( * Now create the object. */ - Tcl_InvalidateStringRep(listPtr); + TclInvalidateStringRep(listPtr); ListSetIntRep(listPtr, listRepPtr); return listPtr; } @@ -302,7 +302,7 @@ Tcl_DbNewListObj( * Now create the object. */ - Tcl_InvalidateStringRep(listPtr); + TclInvalidateStringRep(listPtr); ListSetIntRep(listPtr, listRepPtr); return listPtr; @@ -362,7 +362,7 @@ Tcl_SetListObj( */ TclFreeIntRep(objPtr); - Tcl_InvalidateStringRep(objPtr); + TclInvalidateStringRep(objPtr); /* * Set the object's type to "list" and initialize the internal rep. @@ -697,7 +697,7 @@ Tcl_ListObjAppendElement( * representation has changed. */ - Tcl_InvalidateStringRep(listPtr); + TclInvalidateStringRep(listPtr); return TCL_OK; } @@ -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,10 @@ Tcl_ListObjReplace( if (listRepPtr == NULL) { listRepPtr = AttemptNewList(interp, numRequired, NULL); if (listRepPtr == NULL) { + for (i = 0; i < objc; i++) { + /* See bug 3598580 */ + Tcl_DecrRefCount(objv[i]); + } return TCL_ERROR; } } @@ -1027,14 +1035,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]); } /* @@ -1048,7 +1053,7 @@ Tcl_ListObjReplace( * reflects the list's internal representation. */ - Tcl_InvalidateStringRep(listPtr); + TclInvalidateStringRep(listPtr); return TCL_OK; } @@ -1514,7 +1519,7 @@ TclLsetFlat( * containing lists. */ - Tcl_InvalidateStringRep(objPtr); + TclInvalidateStringRep(objPtr); } /* @@ -1550,7 +1555,7 @@ TclLsetFlat( } else { TclListObjSetElement(NULL, subListPtr, index, valuePtr); } - Tcl_InvalidateStringRep(subListPtr); + TclInvalidateStringRep(subListPtr); Tcl_IncrRefCount(retValuePtr); return retValuePtr; } @@ -1727,8 +1732,6 @@ FreeListInternalRep( ckfree(listRepPtr); } - listPtr->internalRep.twoPtrValue.ptr1 = NULL; - listPtr->internalRep.twoPtrValue.ptr2 = NULL; listPtr->typePtr = NULL; } @@ -1918,8 +1921,8 @@ static void UpdateStringOfList( Tcl_Obj *listPtr) /* List object with string rep to update. */ { -# define LOCAL_SIZE 20 - int localFlags[LOCAL_SIZE], *flagPtr = NULL; +# define LOCAL_SIZE 64 + char localFlags[LOCAL_SIZE], *flagPtr = NULL; List *listRepPtr = ListRepPtr(listPtr); int numElems = listRepPtr->elemCount; int i, length, bytesNeeded = 0; @@ -1956,7 +1959,7 @@ UpdateStringOfList( * We know numElems <= LIST_MAX, so this is safe. */ - flagPtr = ckalloc(numElems * sizeof(int)); + flagPtr = ckalloc(numElems); } elemPtrs = &listRepPtr->elements; for (i = 0; i < numElems; i++) { diff --git a/generic/tclLiteral.c b/generic/tclLiteral.c index 441ea91..e2ee9b4 100644 --- a/generic/tclLiteral.c +++ b/generic/tclLiteral.c @@ -32,6 +32,10 @@ static int AddLocalLiteralEntry(CompileEnv *envPtr, Tcl_Obj *objPtr, int localHash); static void ExpandLocalLiteralArray(CompileEnv *envPtr); static unsigned HashString(const char *string, int length); +#ifdef TCL_COMPILE_DEBUG +static LiteralEntry * LookupLiteralEntry(Tcl_Interp *interp, + Tcl_Obj *objPtr); +#endif static void RebuildLiteralTable(LiteralTable *tablePtr); /* @@ -239,7 +243,7 @@ TclCreateLiteral( } #ifdef TCL_COMPILE_DEBUG - if (TclLookupLiteralEntry((Tcl_Interp *) iPtr, objPtr) != NULL) { + if (LookupLiteralEntry((Tcl_Interp *) iPtr, objPtr) != NULL) { Tcl_Panic("%s: literal \"%.*s\" found globally but shouldn't be", "TclRegisterLiteral", (length>60? 60 : length), bytes); } @@ -301,6 +305,33 @@ TclCreateLiteral( /* *---------------------------------------------------------------------- * + * TclFetchLiteral -- + * + * Fetch from a CompileEnv the literal value identified by an index + * value, as returned by a prior call to TclRegisterLiteral(). + * + * Results: + * The literal value, or NULL if the index is out of range. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclFetchLiteral( + CompileEnv *envPtr, /* Points to the CompileEnv from which to + * fetch the registered literal value. */ + unsigned int index) /* Index of the desired literal, as returned + * by prior call to TclRegisterLiteral() */ +{ + if (index >= envPtr->literalArrayNext) { + return NULL; + } + return envPtr->literalArrayPtr[index].objPtr; +} + +/* + *---------------------------------------------------------------------- + * * TclRegisterLiteral -- * * Find, or if necessary create, an object in a CompileEnv literal array @@ -414,10 +445,11 @@ TclRegisterLiteral( return objIndex; } +#ifdef TCL_COMPILE_DEBUG /* *---------------------------------------------------------------------- * - * TclLookupLiteralEntry -- + * LookupLiteralEntry -- * * Finds the LiteralEntry that corresponds to a literal Tcl object * holding a literal. @@ -431,8 +463,8 @@ TclRegisterLiteral( *---------------------------------------------------------------------- */ -LiteralEntry * -TclLookupLiteralEntry( +static LiteralEntry * +LookupLiteralEntry( Tcl_Interp *interp, /* Interpreter for which objPtr was created to * hold a literal. */ register Tcl_Obj *objPtr) /* Points to a Tcl object holding a literal @@ -456,6 +488,7 @@ TclLookupLiteralEntry( return NULL; } +#endif /* *---------------------------------------------------------------------- * @@ -750,11 +783,16 @@ TclReleaseLiteral( * TclRegisterLiteral. */ { Interp *iPtr = (Interp *) interp; - LiteralTable *globalTablePtr = &iPtr->literalTable; + LiteralTable *globalTablePtr; register LiteralEntry *entryPtr, *prevPtr; const char *bytes; int length, index; + if (iPtr == NULL) { + goto done; + } + + globalTablePtr = &iPtr->literalTable; bytes = TclGetStringFromObj(objPtr, &length); index = (HashString(bytes, length) & globalTablePtr->mask); @@ -798,6 +836,7 @@ TclReleaseLiteral( * Remove the reference corresponding to the local literal table entry. */ + done: Tcl_DecrRefCount(objPtr); } @@ -1090,7 +1129,7 @@ TclVerifyLocalLiteralTable( "TclVerifyLocalLiteralTable", (length>60? 60 : length), bytes, localPtr->refCount); } - if (TclLookupLiteralEntry((Tcl_Interp *) envPtr->iPtr, + if (LookupLiteralEntry((Tcl_Interp *) envPtr->iPtr, localPtr->objPtr) == NULL) { bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length); Tcl_Panic("%s: local literal \"%.*s\" is not global", diff --git a/generic/tclLoadNone.c b/generic/tclLoadNone.c index f030d89..c22c4c4 100644 --- a/generic/tclLoadNone.c +++ b/generic/tclLoadNone.c @@ -82,6 +82,39 @@ TclGuessPackageName( } /* + * These functions are fallbacks if we somehow determine that the platform can + * do loading from memory but the user wishes to disable it. They just report + * (gracefully) that they fail. + */ + +#ifdef TCL_LOAD_FROM_MEMORY + +MODULE_SCOPE void * +TclpLoadMemoryGetBuffer( + Tcl_Interp *interp, /* Dummy: unused by this implementation */ + int size) /* Dummy: unused by this implementation */ +{ + return NULL; +} + +MODULE_SCOPE int +TclpLoadMemory( + Tcl_Interp *interp, /* Used for error reporting. */ + void *buffer, /* Dummy: unused by this implementation */ + int size, /* Dummy: unused by this implementation */ + int codeSize, /* Dummy: unused by this implementation */ + Tcl_LoadHandle *loadHandle, /* Dummy: unused by this implementation */ + Tcl_FSUnloadFileProc **unloadProcPtr) + /* Dummy: unused by this implementation */ +{ + Tcl_SetObjResult(interp, Tcl_NewStringObj("dynamic loading from memory " + "is not available on this system", -1)); + return TCL_ERROR; +} + +#endif /* TCL_LOAD_FROM_MEMORY */ + +/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/generic/tclMain.c b/generic/tclMain.c index 6c71fbb..63e7464 100644 --- a/generic/tclMain.c +++ b/generic/tclMain.c @@ -109,7 +109,7 @@ typedef enum { PROMPT_CONTINUE /* Print prompt for command continuation */ } PromptType; -typedef struct InteractiveState { +typedef struct { Tcl_Channel input; /* The standard input channel from which lines * are read. */ int tty; /* Non-zero means standard input is a @@ -362,7 +362,7 @@ Tcl_MainEx( argc--; argv++; - Tcl_SetVar2Ex(interp, "argc", NULL, Tcl_NewIntObj(argc), TCL_GLOBAL_ONLY); + Tcl_SetVar2Ex(interp, "argc", NULL, Tcl_NewLongObj(argc), TCL_GLOBAL_ONLY); argvPtr = Tcl_NewListObj(0, NULL); while (argc--) { @@ -376,7 +376,7 @@ Tcl_MainEx( is.tty = isatty(0); Tcl_SetVar2Ex(interp, "tcl_interactive", NULL, - Tcl_NewIntObj(!path && is.tty), TCL_GLOBAL_ONLY); + Tcl_NewLongObj(!path && is.tty), TCL_GLOBAL_ONLY); /* * Invoke application-specific initialization. diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 02d517f..edc1a88 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -31,7 +31,7 @@ * limited to a single interpreter. */ -typedef struct ThreadSpecificData { +typedef struct { long numNsCreated; /* Count of the number of namespaces created * within the thread. This value is used as a * unique id for each namespace. Cannot be @@ -52,7 +52,7 @@ static Tcl_ThreadDataKey dataKey; * with some information that is used to check the cached pointer's validity. */ -typedef struct ResolvedNsName { +typedef struct { Namespace *nsPtr; /* A cached pointer to the Namespace that the * name resolved to. */ Namespace *refNsPtr; /* Points to the namespace context in which @@ -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} @@ -343,7 +343,7 @@ Tcl_PushCallFrame( framePtr->clientData = NULL; framePtr->localCachePtr = NULL; framePtr->tailcallPtr = NULL; - + /* * Push the new call frame onto the interpreter's stack of procedure call * frames making it the current frame. @@ -423,7 +423,7 @@ Tcl_PopCallFrame( framePtr->nsPtr = NULL; if (framePtr->tailcallPtr) { - TclSpliceTailcall(interp, framePtr->tailcallPtr); + TclSetTailcall(interp, framePtr->tailcallPtr); } } @@ -505,9 +505,9 @@ EstablishErrorCodeTraces( const char *name2, int flags) { - Tcl_TraceVar(interp, "errorCode", TCL_GLOBAL_ONLY | TCL_TRACE_READS, + Tcl_TraceVar2(interp, "errorCode", NULL, TCL_GLOBAL_ONLY|TCL_TRACE_READS, ErrorCodeRead, NULL); - Tcl_TraceVar(interp, "errorCode", TCL_GLOBAL_ONLY | TCL_TRACE_UNSETS, + Tcl_TraceVar2(interp, "errorCode", NULL, TCL_GLOBAL_ONLY|TCL_TRACE_UNSETS, EstablishErrorCodeTraces, NULL); return NULL; } @@ -579,9 +579,9 @@ EstablishErrorInfoTraces( const char *name2, int flags) { - Tcl_TraceVar(interp, "errorInfo", TCL_GLOBAL_ONLY | TCL_TRACE_READS, + Tcl_TraceVar2(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY|TCL_TRACE_READS, ErrorInfoRead, NULL); - Tcl_TraceVar(interp, "errorInfo", TCL_GLOBAL_ONLY | TCL_TRACE_UNSETS, + Tcl_TraceVar2(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY|TCL_TRACE_UNSETS, EstablishErrorInfoTraces, NULL); return NULL; } @@ -697,8 +697,7 @@ Tcl_CreateNamespace( * Find the parent for the new namespace. */ - TclGetNamespaceForQualName(interp, name, NULL, - /*flags*/ (TCL_CREATE_NS_IF_UNKNOWN | TCL_LEAVE_ERR_MSG), + TclGetNamespaceForQualName(interp, name, NULL, TCL_CREATE_NS_IF_UNKNOWN, &parentPtr, &dummy1Ptr, &dummy2Ptr, &simpleName); /* @@ -1330,8 +1329,7 @@ Tcl_Export( * Check that the pattern doesn't have namespace qualifiers. */ - TclGetNamespaceForQualName(interp, pattern, nsPtr, - /*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY), + TclGetNamespaceForQualName(interp, pattern, nsPtr, TCL_NAMESPACE_ONLY, &exportNsPtr, &dummyPtr, &dummyPtr, &simplePattern); if ((exportNsPtr != nsPtr) || (strcmp(pattern, simplePattern) != 0)) { @@ -1545,8 +1543,7 @@ Tcl_Import( Tcl_SetErrorCode(interp, "TCL", "IMPORT", "EMPTY", NULL); return TCL_ERROR; } - TclGetNamespaceForQualName(interp, pattern, nsPtr, - /*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY), + TclGetNamespaceForQualName(interp, pattern, nsPtr, TCL_NAMESPACE_ONLY, &importNsPtr, &dummyPtr, &dummyPtr, &simplePattern); if (importNsPtr == NULL) { @@ -1791,8 +1788,7 @@ Tcl_ForgetImport( * simple pattern. */ - TclGetNamespaceForQualName(interp, pattern, nsPtr, - /*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY), + TclGetNamespaceForQualName(interp, pattern, nsPtr, TCL_NAMESPACE_ONLY, &sourceNsPtr, &dummyPtr, &dummyPtr, &simplePattern); if (sourceNsPtr == NULL) { @@ -1945,7 +1941,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); } @@ -3025,7 +3021,7 @@ NamespaceCodeCmd( */ arg = TclGetStringFromObj(objv[1], &length); - if (*arg==':' && length > 20 + if (*arg==':' && length > 20 && strncmp(arg, "::namespace inscope ", 20) == 0) { Tcl_SetObjResult(interp, objv[1]); return TCL_OK; @@ -3387,7 +3383,7 @@ NamespaceExistsCmd( return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj( + Tcl_SetObjResult(interp, Tcl_NewLongObj( GetNamespaceFromObj(interp, objv[1], &namespacePtr) == TCL_OK)); return TCL_OK; } @@ -3435,10 +3431,7 @@ NamespaceExportCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Namespace *currNsPtr = (Namespace *) TclGetCurrentNamespace(interp); - const char *pattern, *string; - int resetListFirst = 0; - int firstArg, patternCt, i, result; + int firstArg, i; if (objc < 1) { Tcl_WrongNumArgs(interp, 1, objv, "?-clear? ?pattern pattern...?"); @@ -3446,42 +3439,27 @@ NamespaceExportCmd( } /* - * Process the optional "-clear" argument. + * If no pattern arguments are given, and "-clear" isn't specified, return + * the namespace's current export pattern list. */ - firstArg = 1; - if (firstArg < objc) { - string = TclGetString(objv[firstArg]); - if (strcmp(string, "-clear") == 0) { - resetListFirst = 1; - firstArg++; - } + if (objc == 1) { + Tcl_Obj *listPtr = Tcl_NewObj(); + + (void) Tcl_AppendExportList(interp, NULL, listPtr); + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; } /* - * If no pattern arguments are given, and "-clear" isn't specified, return - * the namespace's current export pattern list. + * Process the optional "-clear" argument. */ - patternCt = objc - firstArg; - if (patternCt == 0) { - if (firstArg > 1) { - return TCL_OK; - } else { - /* - * Create list with export patterns. - */ - - Tcl_Obj *listPtr = Tcl_NewListObj(0, NULL); - - result = Tcl_AppendExportList(interp, (Tcl_Namespace *) currNsPtr, - listPtr); - if (result != TCL_OK) { - return result; - } - Tcl_SetObjResult(interp, listPtr); - return TCL_OK; - } + firstArg = 1; + if (strcmp("-clear", Tcl_GetString(objv[firstArg])) == 0) { + Tcl_Export(interp, NULL, "::", 1); + Tcl_ResetResult(interp); + firstArg++; } /* @@ -3489,9 +3467,7 @@ NamespaceExportCmd( */ for (i = firstArg; i < objc; i++) { - pattern = TclGetString(objv[i]); - result = Tcl_Export(interp, (Tcl_Namespace *) currNsPtr, pattern, - ((i == firstArg)? resetListFirst : 0)); + int result = Tcl_Export(interp, NULL, Tcl_GetString(objv[i]), 0); if (result != TCL_OK) { return result; } @@ -4570,8 +4546,8 @@ NamespaceWhichCmd( * Look for a flag controlling the lookup. */ - if (Tcl_GetIndexFromObj(interp, objv[1], opts, "option", 0, - &lookupType) != TCL_OK) { + if (Tcl_GetIndexFromObjStruct(interp, objv[1], opts, + sizeof(char *), "option", 0, &lookupType) != TCL_OK) { /* * Preserve old style of error message! */ @@ -4918,7 +4894,7 @@ TclLogCommandInfo( if (Tcl_IsShared(iPtr->errorStack)) { Tcl_Obj *newObj; - + newObj = Tcl_DuplicateObj(iPtr->errorStack); Tcl_DecrRefCount(iPtr->errorStack); Tcl_IncrRefCount(newObj); @@ -4950,7 +4926,7 @@ TclLogCommandInfo( Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewStringObj(command, length)); } - } + } if (!iPtr->framePtr->objc) { /* @@ -4962,7 +4938,7 @@ TclLogCommandInfo( */ Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->upLiteral); - Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewIntObj( + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewLongObj( iPtr->framePtr->level - iPtr->varFramePtr->level)); } else if (iPtr->framePtr != iPtr->rootFramePtr) { /* @@ -5003,7 +4979,7 @@ TclErrorStackResetIf( if (Tcl_IsShared(iPtr->errorStack)) { Tcl_Obj *newObj; - + newObj = Tcl_DuplicateObj(iPtr->errorStack); Tcl_DecrRefCount(iPtr->errorStack); Tcl_IncrRefCount(newObj); @@ -5023,7 +4999,7 @@ TclErrorStackResetIf( Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->innerLiteral); Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewStringObj(msg, length)); - } + } } /* diff --git a/generic/tclOO.c b/generic/tclOO.c index d6d2d6a..2593234 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -267,7 +267,7 @@ TclOOInit( * to be fully provided. */ - if (Tcl_Eval(interp, initScript) != TCL_OK) { + if (Tcl_EvalEx(interp, initScript, -1, 0) != TCL_OK) { return TCL_ERROR; } @@ -458,7 +458,7 @@ InitFoundation( if (TclOODefineSlots(fPtr) != TCL_OK) { return TCL_ERROR; } - return Tcl_Eval(interp, slotScript); + return Tcl_EvalEx(interp, slotScript, -1, 0); } /* @@ -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/tclOOBasic.c b/generic/tclOOBasic.c index 0676618..5e29512 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -687,52 +687,51 @@ TclOO_Object_VarName( int objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* The actual arguments. */ { - Interp *iPtr = (Interp *) interp; Var *varPtr, *aryVar; - Tcl_Obj *varNamePtr; + Tcl_Obj *varNamePtr, *argPtr; + const char *arg; if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, "varName"); return TCL_ERROR; } + argPtr = objv[objc-1]; + arg = Tcl_GetString(argPtr); /* - * Switch to the object's namespace for the duration of this call. Like - * this, the variable is looked up in the namespace of the object, and not - * in the namespace of the caller. Otherwise this would only work if the - * caller was a method of the object itself, which might not be true if - * the method was exported. This is a bit of a hack, but the simplest way - * to do this (pushing a stack frame would be horribly expensive by - * comparison, and is only done when we'd otherwise interfere with the - * global namespace). + * Convert the variable name to fully-qualified form if it wasn't already. + * This has to be done prior to lookup because we can run into problems + * with resolvers otherwise. [Bug 3603695] + * + * We still need to do the lookup; the variable could be linked to another + * variable and we want the target's name. */ - if (iPtr->varFramePtr == NULL) { - Tcl_CallFrame *dummyFrame; - - TclPushStackFrame(interp, &dummyFrame, - Tcl_GetObjectNamespace(Tcl_ObjectContextObject(context)),0); - varPtr = TclObjLookupVar(interp, objv[objc-1], NULL, - TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG, "refer to",1,1,&aryVar); - TclPopStackFrame(interp); + if (arg[0] == ':' && arg[1] == ':') { + varNamePtr = argPtr; } else { - Namespace *savedNsPtr; - - savedNsPtr = iPtr->varFramePtr->nsPtr; - iPtr->varFramePtr->nsPtr = (Namespace *) + Tcl_Namespace *namespacePtr = Tcl_GetObjectNamespace(Tcl_ObjectContextObject(context)); - varPtr = TclObjLookupVar(interp, objv[objc-1], NULL, - TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG, "refer to",1,1,&aryVar); - iPtr->varFramePtr->nsPtr = savedNsPtr; - } + varNamePtr = Tcl_NewStringObj(namespacePtr->fullName, -1); + Tcl_AppendToObj(varNamePtr, "::", 2); + Tcl_AppendObjToObj(varNamePtr, argPtr); + } + Tcl_IncrRefCount(varNamePtr); + varPtr = TclObjLookupVar(interp, varNamePtr, NULL, + TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG, "refer to", 1, 1, &aryVar); + Tcl_DecrRefCount(varNamePtr); if (varPtr == NULL) { - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", - TclGetString(objv[objc-1]), NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", arg, NULL); return TCL_ERROR; } + /* + * Now that we've pinned down what variable we're really talking about + * (including traversing variable links), convert back to a name. + */ + varNamePtr = Tcl_NewObj(); if (aryVar != NULL) { Tcl_HashEntry *hPtr; @@ -979,8 +978,8 @@ TclOOSelfObjCmd( return TCL_ERROR; } else if (objc == 1) { index = SELF_OBJECT; - } else if (Tcl_GetIndexFromObj(interp, objv[1], subcmds, "subcommand", 0, - &index) != TCL_OK) { + } else if (Tcl_GetIndexFromObjStruct(interp, objv[1], subcmds, + sizeof(char *), "subcommand", 0, &index) != TCL_OK) { return TCL_ERROR; } @@ -1149,7 +1148,7 @@ TclOOSelfObjCmd( } case SELF_CALL: result[0] = TclOORenderCallChain(interp, contextPtr->callPtr); - result[1] = Tcl_NewIntObj(contextPtr->index); + result[1] = Tcl_NewLongObj(contextPtr->index); Tcl_SetObjResult(interp, Tcl_NewListObj(2, result)); return TCL_OK; } diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index a79e4fa..26fd09f 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -178,7 +178,7 @@ StashCallChain( callPtr->refCount++; TclFreeIntRep(objPtr); objPtr->typePtr = &methodNameType; - objPtr->internalRep.otherValuePtr = callPtr; + objPtr->internalRep.twoPtrValue.ptr1 = callPtr; } void @@ -205,10 +205,10 @@ DupMethodNameRep( Tcl_Obj *srcPtr, Tcl_Obj *dstPtr) { - register CallChain *callPtr = srcPtr->internalRep.otherValuePtr; + register CallChain *callPtr = srcPtr->internalRep.twoPtrValue.ptr1; dstPtr->typePtr = &methodNameType; - dstPtr->internalRep.otherValuePtr = callPtr; + dstPtr->internalRep.twoPtrValue.ptr1 = callPtr; callPtr->refCount++; } @@ -216,10 +216,9 @@ static void FreeMethodNameRep( Tcl_Obj *objPtr) { - register CallChain *callPtr = objPtr->internalRep.otherValuePtr; + register CallChain *callPtr = objPtr->internalRep.twoPtrValue.ptr1; TclOODeleteChain(callPtr); - objPtr->internalRep.otherValuePtr = NULL; objPtr->typePtr = NULL; } @@ -952,7 +951,7 @@ TclOOGetCallContext( const int reuseMask = ((flags & PUBLIC_METHOD) ? ~0 : ~PUBLIC_METHOD); if (cacheInThisObj->typePtr == &methodNameType) { - callPtr = cacheInThisObj->internalRep.otherValuePtr; + callPtr = cacheInThisObj->internalRep.twoPtrValue.ptr1; if (IsStillValid(callPtr, oPtr, flags, reuseMask)) { callPtr->refCount++; goto returnContext; diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c index e09ee4e..cbf49d3 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); } /* @@ -209,11 +197,11 @@ InfoObjectClassCmd( FOREACH(mixinPtr, oPtr->mixins) { if (TclOOIsReachable(o2clsPtr, mixinPtr)) { - Tcl_SetObjResult(interp, Tcl_NewIntObj(1)); + Tcl_SetObjResult(interp, Tcl_NewLongObj(1)); return TCL_OK; } } - Tcl_SetObjResult(interp, Tcl_NewIntObj( + Tcl_SetObjResult(interp, Tcl_NewLongObj( TclOOIsReachable(o2clsPtr, oPtr->selfCls))); return TCL_OK; } @@ -430,7 +418,7 @@ InfoObjectIsACmd( if (!ok) { Tcl_ResetResult(interp); } - Tcl_SetObjResult(interp, Tcl_NewIntObj(ok ? 1 : 0)); + Tcl_SetObjResult(interp, Tcl_NewLongObj(ok!=0)); return TCL_OK; } oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]); @@ -444,7 +432,7 @@ InfoObjectIsACmd( Tcl_WrongNumArgs(interp, 2, objv, "objName"); return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_NewIntObj(oPtr->classPtr ? 1 : 0)); + Tcl_SetObjResult(interp, Tcl_NewLongObj(oPtr->classPtr!=NULL)); return TCL_OK; case IsMetaclass: if (objc != 3) { @@ -452,12 +440,12 @@ InfoObjectIsACmd( return TCL_ERROR; } if (oPtr->classPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); + Tcl_SetObjResult(interp, Tcl_NewLongObj(0)); } else { Class *classCls = TclOOGetFoundation(interp)->classCls; - Tcl_SetObjResult(interp, Tcl_NewIntObj( - TclOOIsReachable(classCls, oPtr->classPtr) ? 1 : 0)); + Tcl_SetObjResult(interp, Tcl_NewLongObj( + TclOOIsReachable(classCls, oPtr->classPtr)!=0)); } return TCL_OK; case IsMixin: @@ -479,12 +467,12 @@ InfoObjectIsACmd( FOREACH(mixinPtr, oPtr->mixins) { if (mixinPtr == o2Ptr->classPtr) { - Tcl_SetObjResult(interp, Tcl_NewIntObj(1)); + Tcl_SetObjResult(interp, Tcl_NewLongObj(1)); return TCL_OK; } } } - Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); + Tcl_SetObjResult(interp, Tcl_NewLongObj(0)); return TCL_OK; case IsType: if (objc != 4) { @@ -502,9 +490,9 @@ InfoObjectIsACmd( return TCL_ERROR; } if (TclOOIsReachable(o2Ptr->classPtr, oPtr->selfCls)) { - Tcl_SetObjResult(interp, Tcl_NewIntObj(1)); + Tcl_SetObjResult(interp, Tcl_NewLongObj(1)); } else { - Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); + Tcl_SetObjResult(interp, Tcl_NewLongObj(0)); } return TCL_OK; case IsObject: diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index 28820e0..98b4078 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -860,7 +860,7 @@ PushMethodCallFrame( if (pmPtr->procPtr->bodyPtr->typePtr == &tclByteCodeType) { ByteCode *codePtr = - pmPtr->procPtr->bodyPtr->internalRep.otherValuePtr; + pmPtr->procPtr->bodyPtr->internalRep.twoPtrValue.ptr1; codePtr->nsPtr = nsPtr; } 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/tclObj.c b/generic/tclObj.c index 74cb29e..b62c088 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -58,7 +58,7 @@ char *tclEmptyStringRep = &tclEmptyString; * for sanity checking purposes. */ -typedef struct ObjData { +typedef struct { Tcl_Obj *objPtr; /* The pointer to the allocated Tcl_Obj. */ const char *file; /* The name of the source file calling this * function; used for debugging. */ @@ -208,7 +208,6 @@ static Tcl_ThreadDataKey pendingObjDataKey; */ static int ParseBoolean(Tcl_Obj *objPtr); -static int SetBooleanFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static int SetDoubleFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static int SetIntFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static void UpdateStringOfDouble(Tcl_Obj *objPtr); @@ -250,14 +249,14 @@ static const Tcl_ObjType oldBooleanType = { NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ NULL, /* updateStringProc */ - SetBooleanFromAny /* setFromAnyProc */ + TclSetBooleanFromAny /* setFromAnyProc */ }; const Tcl_ObjType tclBooleanType = { "booleanString", /* name */ NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ NULL, /* updateStringProc */ - SetBooleanFromAny /* setFromAnyProc */ + TclSetBooleanFromAny /* setFromAnyProc */ }; const Tcl_ObjType tclDoubleType = { "double", /* name */ @@ -1006,7 +1005,12 @@ Tcl_ConvertToType( */ if (typePtr->setFromAnyProc == NULL) { - Tcl_Panic("may not convert object to type %s", typePtr->name); + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't convert value to type %s", typePtr->name)); + Tcl_SetErrorCode(interp, "TCL", "API_ABUSE", NULL); + } + return TCL_ERROR; } return typePtr->setFromAnyProc(interp, objPtr); @@ -1255,7 +1259,7 @@ Tcl_DbNewObj( * Side effects: * tclFreeObjList, the head of the list of free Tcl_Objs, is set to the * first of a number of free Tcl_Obj's linked together by their - * internalRep.otherValuePtrs. + * internalRep.twoPtrValue.ptr1's. * *---------------------------------------------------------------------- */ @@ -1284,7 +1288,7 @@ TclAllocateFreeObjects(void) prevPtr = NULL; objPtr = (Tcl_Obj *) basePtr; for (i = 0; i < OBJS_TO_ALLOC_EACH_TIME; i++) { - objPtr->internalRep.otherValuePtr = prevPtr; + objPtr->internalRep.twoPtrValue.ptr1 = prevPtr; prevPtr = objPtr; objPtr++; } @@ -1709,142 +1713,6 @@ Tcl_InvalidateStringRep( /* *---------------------------------------------------------------------- * - * Tcl_NewBooleanObj -- - * - * This function is normally called when not debugging: i.e., when - * TCL_MEM_DEBUG is not defined. It creates a new Tcl_Obj and - * initializes it from the argument boolean value. A nonzero "boolValue" - * is coerced to 1. - * - * When TCL_MEM_DEBUG is defined, this function just returns the result - * of calling the debugging version Tcl_DbNewBooleanObj. - * - * Results: - * The newly created object is returned. This object will have an invalid - * string representation. The returned object has ref count 0. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -#ifdef TCL_MEM_DEBUG -#undef Tcl_NewBooleanObj - -Tcl_Obj * -Tcl_NewBooleanObj( - register int boolValue) /* Boolean used to initialize new object. */ -{ - return Tcl_DbNewBooleanObj(boolValue, "unknown", 0); -} - -#else /* if not TCL_MEM_DEBUG */ - -Tcl_Obj * -Tcl_NewBooleanObj( - register int boolValue) /* Boolean used to initialize new object. */ -{ - register Tcl_Obj *objPtr; - - TclNewBooleanObj(objPtr, boolValue); - return objPtr; -} -#endif /* TCL_MEM_DEBUG */ - -/* - *---------------------------------------------------------------------- - * - * Tcl_DbNewBooleanObj -- - * - * This function is normally called when debugging: i.e., when - * TCL_MEM_DEBUG is defined. It creates new boolean objects. It is the - * same as the Tcl_NewBooleanObj function above except that it calls - * Tcl_DbCkalloc directly with the file name and line number from its - * caller. This simplifies debugging since then the [memory active] - * command will report the correct file name and line number when - * reporting objects that haven't been freed. - * - * When TCL_MEM_DEBUG is not defined, this function just returns the - * result of calling Tcl_NewBooleanObj. - * - * Results: - * The newly created object is returned. This object will have an invalid - * string representation. The returned object has ref count 0. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -#ifdef TCL_MEM_DEBUG - -Tcl_Obj * -Tcl_DbNewBooleanObj( - register int boolValue, /* Boolean used to initialize new object. */ - const char *file, /* The name of the source file calling this - * function; used for debugging. */ - int line) /* Line number in the source file; used for - * debugging. */ -{ - register Tcl_Obj *objPtr; - - TclDbNewObj(objPtr, file, line); - objPtr->bytes = NULL; - - objPtr->internalRep.longValue = (boolValue? 1 : 0); - objPtr->typePtr = &tclIntType; - return objPtr; -} - -#else /* if not TCL_MEM_DEBUG */ - -Tcl_Obj * -Tcl_DbNewBooleanObj( - register int boolValue, /* Boolean used to initialize new object. */ - const char *file, /* The name of the source file calling this - * function; used for debugging. */ - int line) /* Line number in the source file; used for - * debugging. */ -{ - return Tcl_NewBooleanObj(boolValue); -} -#endif /* TCL_MEM_DEBUG */ - -/* - *---------------------------------------------------------------------- - * - * Tcl_SetBooleanObj -- - * - * Modify an object to be a boolean object and to have the specified - * boolean value. A nonzero "boolValue" is coerced to 1. - * - * Results: - * None. - * - * Side effects: - * The object's old string rep, if any, is freed. Also, any old internal - * rep is freed. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_SetBooleanObj( - register Tcl_Obj *objPtr, /* Object whose internal rep to init. */ - register int boolValue) /* Boolean used to set object's value. */ -{ - if (Tcl_IsShared(objPtr)) { - Tcl_Panic("%s called with shared object", "Tcl_SetBooleanObj"); - } - - TclSetBooleanObj(objPtr, boolValue); -} - -/* - *---------------------------------------------------------------------- - * * Tcl_GetBooleanFromObj -- * * Attempt to return a boolean from the Tcl object "objPtr". This @@ -1911,7 +1779,7 @@ Tcl_GetBooleanFromObj( /* *---------------------------------------------------------------------- * - * SetBooleanFromAny -- + * TclSetBooleanFromAny -- * * Attempt to generate a boolean internal form for the Tcl object * "objPtr". @@ -1928,8 +1796,8 @@ Tcl_GetBooleanFromObj( *---------------------------------------------------------------------- */ -static int -SetBooleanFromAny( +int +TclSetBooleanFromAny( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ register Tcl_Obj *objPtr) /* The object to convert. */ { @@ -2362,89 +2230,6 @@ UpdateStringOfDouble( /* *---------------------------------------------------------------------- * - * Tcl_NewIntObj -- - * - * If a client is compiled with TCL_MEM_DEBUG defined, calls to - * Tcl_NewIntObj to create a new integer object end up calling the - * debugging function Tcl_DbNewLongObj instead. - * - * Otherwise, if the client is compiled without TCL_MEM_DEBUG defined, - * calls to Tcl_NewIntObj result in a call to one of the two - * Tcl_NewIntObj implementations below. We provide two implementations so - * that the Tcl core can be compiled to do memory debugging of the core - * even if a client does not request it for itself. - * - * Integer and long integer objects share the same "integer" type - * implementation. We store all integers as longs and Tcl_GetIntFromObj - * checks whether the current value of the long can be represented by an - * int. - * - * Results: - * The newly created object is returned. This object will have an invalid - * string representation. The returned object has ref count 0. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -#ifdef TCL_MEM_DEBUG -#undef Tcl_NewIntObj - -Tcl_Obj * -Tcl_NewIntObj( - register int intValue) /* Int used to initialize the new object. */ -{ - return Tcl_DbNewLongObj((long)intValue, "unknown", 0); -} - -#else /* if not TCL_MEM_DEBUG */ - -Tcl_Obj * -Tcl_NewIntObj( - register int intValue) /* Int used to initialize the new object. */ -{ - register Tcl_Obj *objPtr; - - TclNewIntObj(objPtr, intValue); - return objPtr; -} -#endif /* if TCL_MEM_DEBUG */ - -/* - *---------------------------------------------------------------------- - * - * Tcl_SetIntObj -- - * - * Modify an object to be an integer and to have the specified integer - * value. - * - * Results: - * None. - * - * Side effects: - * The object's old string rep, if any, is freed. Also, any old internal - * rep is freed. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_SetIntObj( - register Tcl_Obj *objPtr, /* Object whose internal rep to init. */ - register int intValue) /* Integer used to set object's value. */ -{ - if (Tcl_IsShared(objPtr)) { - Tcl_Panic("%s called with shared object", "Tcl_SetIntObj"); - } - - TclSetIntObj(objPtr, intValue); -} - -/* - *---------------------------------------------------------------------- - * * Tcl_GetIntFromObj -- * * Attempt to return an int from the Tcl object "objPtr". If the object @@ -2616,11 +2401,11 @@ Tcl_NewLongObj( * Tcl_DbNewLongObj -- * * If a client is compiled with TCL_MEM_DEBUG defined, calls to - * Tcl_NewIntObj and Tcl_NewLongObj to create new integer or long integer - * objects end up calling the debugging function Tcl_DbNewLongObj - * instead. We provide two implementations of Tcl_DbNewLongObj so that - * whether the Tcl core is compiled to do memory debugging of the core is - * independent of whether a client requests debugging for itself. + * Tcl_NewLongObj to create new long integer objects end up calling the + * debugging function Tcl_DbNewLongObj instead. We provide two + * implementations of Tcl_DbNewLongObj so that whether the Tcl core is + * compiled to do memory debugging of the core is independent of whether + * a client requests debugging for itself. * * When the core is compiled with TCL_MEM_DEBUG defined, Tcl_DbNewLongObj * calls Tcl_DbCkalloc directly with the file name and line number from @@ -3784,7 +3569,7 @@ Tcl_DbDecrRefCount( * If the Tcl_Obj is going to be deleted, remove the entry. */ - if ((objPtr->refCount - 1) <= 0) { + if (objPtr->refCount < 2) { ObjData *objData = Tcl_GetHashValue(hPtr); if (objData != NULL) { @@ -3797,7 +3582,7 @@ Tcl_DbDecrRefCount( # endif /* TCL_THREADS */ #endif /* TCL_MEM_DEBUG */ - if (--(objPtr)->refCount <= 0) { + if ((objPtr)->refCount-- < 2) { TclFreeObj(objPtr); } } @@ -4171,7 +3956,7 @@ Tcl_GetCommandFromObj( * had is invalid one way or another. */ - if (tclCmdNameType.setFromAnyProc(interp, objPtr) != TCL_OK) { + if (SetCmdNameFromAny(interp, objPtr) != TCL_OK) { return NULL; } resPtr = objPtr->internalRep.twoPtrValue.ptr1; @@ -4390,7 +4175,7 @@ SetCmdNameFromAny( if (cmdPtr) { cmdPtr->refCount++; - resPtr = objPtr->internalRep.otherValuePtr; + resPtr = objPtr->internalRep.twoPtrValue.ptr1; if ((objPtr->typePtr == &tclCmdNameType) && resPtr && (resPtr->refCount == 1)) { /* diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index 2b9ff87..ea5c1b8 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -71,7 +71,7 @@ static const Tcl_ObjType tclFsPathType = { * */ -typedef struct FsPath { +typedef struct { Tcl_Obj *translatedPathPtr; /* Name without any ~user sequences. If this * is NULL, then this is a pure normalized, * absolute path object, in which the parent @@ -109,9 +109,9 @@ typedef struct FsPath { * fields. */ -#define PATHOBJ(pathPtr) ((FsPath *) (pathPtr)->internalRep.otherValuePtr) +#define PATHOBJ(pathPtr) ((FsPath *) (pathPtr)->internalRep.twoPtrValue.ptr1) #define SETPATHOBJ(pathPtr,fsPathPtr) \ - ((pathPtr)->internalRep.otherValuePtr = (void *) (fsPathPtr)) + ((pathPtr)->internalRep.twoPtrValue.ptr1 = (void *) (fsPathPtr)) #define PATHFLAGS(pathPtr) (PATHOBJ(pathPtr)->flags) /* @@ -1156,7 +1156,7 @@ Tcl_FSConvertToPathType( FreeFsPathInternalRep(pathPtr); } - return Tcl_ConvertToType(interp, pathPtr, &tclFsPathType); + return SetFsPathFromAny(interp, pathPtr); /* * We used to have more complex code here: @@ -1873,7 +1873,7 @@ Tcl_FSGetNormalizedPath( UpdateStringOfFsPath(pathPtr); } FreeFsPathInternalRep(pathPtr); - if (Tcl_ConvertToType(interp, pathPtr, &tclFsPathType) != TCL_OK) { + if (SetFsPathFromAny(interp, pathPtr) != TCL_OK) { return NULL; } fsPathPtr = PATHOBJ(pathPtr); diff --git a/generic/tclPkg.c b/generic/tclPkg.c index 312524a..ec5d0e6 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -39,7 +39,7 @@ typedef struct PkgAvail { * "Tk" (no version number). */ -typedef struct Package { +typedef struct { char *version; /* Version that has been supplied in this * interpreter via "package provide" * (malloc'ed). NULL means the package doesn't @@ -88,7 +88,7 @@ static const char * PkgRequireCore(Tcl_Interp *interp, const char *name, /* *---------------------------------------------------------------------- * - * Tcl_PkgProvide / Tcl_PkgProvideEx -- + * Tcl_PkgProvideEx -- * * This function is invoked to declare that a particular version of a * particular package is now present in an interpreter. There must not be @@ -154,7 +154,7 @@ Tcl_PkgProvideEx( /* *---------------------------------------------------------------------- * - * Tcl_PkgRequire / Tcl_PkgRequireEx / Tcl_PkgRequireProc -- + * Tcl_PkgRequireEx / Tcl_PkgRequireProc -- * * This function is called by code that depends on a particular version * of a particular package. If the package is not already provided in the @@ -179,20 +179,6 @@ Tcl_PkgProvideEx( */ const char * -Tcl_PkgRequire( - Tcl_Interp *interp, /* Interpreter in which package is now - * available. */ - const char *name, /* Name of desired package. */ - const char *version, /* Version string for desired version; NULL - * means use the latest version available. */ - int exact) /* Non-zero means that only the particular - * version given is acceptable. Zero means use - * the latest compatible version. */ -{ - return Tcl_PkgRequireEx(interp, name, version, exact, NULL); -} - -const char * Tcl_PkgRequireEx( Tcl_Interp *interp, /* Interpreter in which package is now * available. */ @@ -642,7 +628,7 @@ PkgRequireCore( /* *---------------------------------------------------------------------- * - * Tcl_PkgPresent / Tcl_PkgPresentEx -- + * Tcl_PkgPresentEx -- * * Checks to see whether the specified package is present. If it is not * then no additional action is taken. @@ -661,20 +647,6 @@ PkgRequireCore( */ const char * -Tcl_PkgPresent( - Tcl_Interp *interp, /* Interpreter in which package is now - * available. */ - const char *name, /* Name of desired package. */ - const char *version, /* Version string for desired version; NULL - * means use the latest version available. */ - int exact) /* Non-zero means that only the particular - * version given is acceptable. Zero means use - * the latest compatible version. */ -{ - return Tcl_PkgPresentEx(interp, name, version, exact, NULL); -} - -const char * Tcl_PkgPresentEx( Tcl_Interp *interp, /* Interpreter in which package is now * available. */ @@ -936,7 +908,7 @@ Tcl_PackageObjCmd( version = TclGetString(objv[3]); } } - Tcl_PkgPresent(interp, name, version, exact); + Tcl_PkgPresentEx(interp, name, version, exact, NULL); return TCL_ERROR; break; } @@ -961,7 +933,7 @@ Tcl_PackageObjCmd( if (CheckVersionAndConvert(interp, argv3, NULL, NULL) != TCL_OK) { return TCL_ERROR; } - return Tcl_PkgProvide(interp, argv2, argv3); + return Tcl_PkgProvideEx(interp, argv2, argv3, NULL); case PKG_REQUIRE: require: if (objc < 3) { @@ -1880,7 +1852,7 @@ Tcl_PkgInitStubsCheck( const char * version, int exact) { - const char *actualVersion = Tcl_PkgPresent(interp, "Tcl", version, 0); + const char *actualVersion = Tcl_PkgPresentEx(interp, "Tcl", version, 0, NULL); if (exact && actualVersion) { const char *p = version; @@ -1892,11 +1864,11 @@ Tcl_PkgInitStubsCheck( if (count == 1) { if (0 != strncmp(version, actualVersion, strlen(version))) { /* Construct error message */ - Tcl_PkgPresent(interp, "Tcl", version, 1); + Tcl_PkgPresentEx(interp, "Tcl", version, 1, NULL); return NULL; } } else { - return Tcl_PkgPresent(interp, "Tcl", version, 1); + return Tcl_PkgPresentEx(interp, "Tcl", version, 1, NULL); } } return actualVersion; 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/tclPreserve.c b/generic/tclPreserve.c index 0bd8f93..62c8de4 100644 --- a/generic/tclPreserve.c +++ b/generic/tclPreserve.c @@ -53,7 +53,7 @@ TCL_DECLARE_MUTEX(preserveMutex)/* To protect the above statics */ * objects that we don't want to live any longer than necessary. */ -typedef struct HandleStruct { +typedef struct { void *ptr; /* Pointer to the memory block being tracked. * This field will become NULL when the memory * block is deleted. This field must be the diff --git a/generic/tclProc.c b/generic/tclProc.c index 933e7d2..29f0772 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -421,7 +421,7 @@ TclCreateProc( * will be holding a reference to it. */ - procPtr = bodyPtr->internalRep.otherValuePtr; + procPtr = bodyPtr->internalRep.twoPtrValue.ptr1; procPtr->iPtr = iPtr; procPtr->refCount++; precompiled = 1; @@ -1197,7 +1197,7 @@ TclInitCompiledLocals( if (bodyPtr->typePtr != &tclByteCodeType) { Tcl_Panic("body object for proc attached to frame is not a byte code type"); } - codePtr = bodyPtr->internalRep.otherValuePtr; + codePtr = bodyPtr->internalRep.twoPtrValue.ptr1; if (framePtr->numCompiledLocals) { if (!codePtr->localCachePtr) { @@ -1347,17 +1347,9 @@ TclFreeLocalCache( for (i = 0; i < localCachePtr->numVars; i++, namePtrPtr++) { register Tcl_Obj *objPtr = *namePtrPtr; - /* - * Note that this can be called with interp==NULL, on interp deletion. - * In that case, the literal table and objects go away on their own. - */ - if (objPtr) { - if (interp) { - TclReleaseLiteral(interp, objPtr); - } else { - Tcl_DecrRefCount(objPtr); - } + /* TclReleaseLiteral calls Tcl_DecrRefCount for us */ + TclReleaseLiteral(interp, objPtr); } } ckfree(localCachePtr); @@ -1368,7 +1360,7 @@ InitLocalCache( Proc *procPtr) { Interp *iPtr = procPtr->iPtr; - ByteCode *codePtr = procPtr->bodyPtr->internalRep.otherValuePtr; + ByteCode *codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1; int localCt = procPtr->numCompiledLocals; int numArgs = procPtr->numArgs, i = 0; @@ -1445,7 +1437,7 @@ InitArgsAndLocals( { CallFrame *framePtr = ((Interp *)interp)->varFramePtr; register Proc *procPtr = framePtr->procPtr; - ByteCode *codePtr = procPtr->bodyPtr->internalRep.otherValuePtr; + ByteCode *codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1; register Var *varPtr, *defPtr; int localCt = procPtr->numCompiledLocals, numArgs, argCt, i, imax; Tcl_Obj *const *argObjs; @@ -1632,7 +1624,7 @@ PushProcCallFrame( * commands and/or resolver changes are considered). */ - codePtr = procPtr->bodyPtr->internalRep.otherValuePtr; + codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1; if (((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) || (codePtr->nsPtr != nsPtr) @@ -1833,7 +1825,7 @@ TclNRInterpProcCore( */ procPtr->refCount++; - codePtr = procPtr->bodyPtr->internalRep.otherValuePtr; + codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1; TclNRAddCallback(interp, InterpProcNR2, procNameObj, errorProc, NULL, NULL); @@ -1975,7 +1967,7 @@ TclProcCompileProc( { Interp *iPtr = (Interp *) interp; Tcl_CallFrame *framePtr; - ByteCode *codePtr = bodyPtr->internalRep.otherValuePtr; + ByteCode *codePtr = bodyPtr->internalRep.twoPtrValue.ptr1; /* * If necessary, compile the procedure's body. The compiler will allocate @@ -2095,7 +2087,7 @@ TclProcCompileProc( iPtr->invokeWord = 0; iPtr->invokeCmdFramePtr = (hePtr ? Tcl_GetHashValue(hePtr) : NULL); - tclByteCodeType.setFromAnyProc(interp, bodyPtr); + TclSetByteCodeFromAny(interp, bodyPtr, NULL, NULL); iPtr->invokeCmdFramePtr = NULL; TclPopStackFrame(interp); } else if (codePtr->nsEpoch != nsPtr->resolverEpoch) { @@ -2365,7 +2357,7 @@ TclNewProcBodyObj( TclNewObj(objPtr); if (objPtr) { objPtr->typePtr = &tclProcBodyType; - objPtr->internalRep.otherValuePtr = procPtr; + objPtr->internalRep.twoPtrValue.ptr1 = procPtr; procPtr->refCount++; } @@ -2395,10 +2387,10 @@ ProcBodyDup( Tcl_Obj *srcPtr, /* Object to copy. */ Tcl_Obj *dupPtr) /* Target object for the duplication. */ { - Proc *procPtr = srcPtr->internalRep.otherValuePtr; + Proc *procPtr = srcPtr->internalRep.twoPtrValue.ptr1; dupPtr->typePtr = &tclProcBodyType; - dupPtr->internalRep.otherValuePtr = procPtr; + dupPtr->internalRep.twoPtrValue.ptr1 = procPtr; procPtr->refCount++; } @@ -2425,10 +2417,9 @@ static void ProcBodyFree( Tcl_Obj *objPtr) /* The object to clean up. */ { - Proc *procPtr = objPtr->internalRep.otherValuePtr; + Proc *procPtr = objPtr->internalRep.twoPtrValue.ptr1; - procPtr->refCount--; - if (procPtr->refCount <= 0) { + if (procPtr->refCount-- < 2) { TclProcCleanupProc(procPtr); } } @@ -2721,7 +2712,6 @@ TclNRApplyObjCmd( else { /* * Joe English's suggestion to allow cmdNames to function as lambdas. - * Also requires making tclCmdNameType non-static in tclObj.c */ Tcl_Obj *elemPtr; @@ -2881,7 +2871,8 @@ Tcl_DisassembleObjCmd( Tcl_WrongNumArgs(interp, 1, objv, "type ..."); return TCL_ERROR; } - if (Tcl_GetIndexFromObj(interp, objv[1], types, "type", 0, &idx)!=TCL_OK){ + if (Tcl_GetIndexFromObjStruct(interp, objv[1], types, + sizeof(char *), "type", 0, &idx) != TCL_OK){ return TCL_ERROR; } @@ -2961,10 +2952,9 @@ Tcl_DisassembleObjCmd( Tcl_WrongNumArgs(interp, 2, objv, "script"); return TCL_ERROR; } - if (objv[2]->typePtr != &tclByteCodeType) { - if (TclSetByteCodeFromAny(interp, objv[2], NULL, NULL) != TCL_OK){ - return TCL_ERROR; - } + if ((objv[2]->typePtr != &tclByteCodeType) + && (TclSetByteCodeFromAny(interp, objv[2], NULL, NULL) != TCL_OK)) { + return TCL_ERROR; } codeObjPtr = objv[2]; break; @@ -3061,7 +3051,7 @@ Tcl_DisassembleObjCmd( * Do the actual disassembly. */ - if (((ByteCode *) codeObjPtr->internalRep.otherValuePtr)->flags + if (((ByteCode *) codeObjPtr->internalRep.twoPtrValue.ptr1)->flags & TCL_BYTECODE_PRECOMPILED) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "may not disassemble prebuilt bytecode", -1)); diff --git a/generic/tclRegexp.c b/generic/tclRegexp.c index 6c1dc08..030be1d 100644 --- a/generic/tclRegexp.c +++ b/generic/tclRegexp.c @@ -64,7 +64,7 @@ #define NUM_REGEXPS 30 -typedef struct ThreadSpecificData { +typedef struct { int initialized; /* Set to 1 when the module is initialized. */ char *patterns[NUM_REGEXPS];/* Strings corresponding to compiled regular * expression patterns. NULL means that this @@ -578,7 +578,7 @@ Tcl_GetRegExpFromObj( * TclRegexp* when the type is tclRegexpType. */ - regexpPtr = objPtr->internalRep.otherValuePtr; + regexpPtr = objPtr->internalRep.twoPtrValue.ptr1; if ((objPtr->typePtr != &tclRegexpType) || (regexpPtr->flags != flags)) { pattern = TclGetStringFromObj(objPtr, &length); @@ -601,7 +601,7 @@ Tcl_GetRegExpFromObj( */ TclFreeIntRep(objPtr); - objPtr->internalRep.otherValuePtr = regexpPtr; + objPtr->internalRep.twoPtrValue.ptr1 = regexpPtr; objPtr->typePtr = &tclRegexpType; } return (Tcl_RegExp) regexpPtr; @@ -672,7 +672,7 @@ TclRegAbout( resultObj = Tcl_NewObj(); Tcl_ListObjAppendElement(NULL, resultObj, - Tcl_NewIntObj((int) regexpPtr->re.re_nsub)); + Tcl_NewLongObj((long) regexpPtr->re.re_nsub)); /* * Now append a list of all the bit-flags set for the RE. @@ -749,7 +749,7 @@ static void FreeRegexpInternalRep( Tcl_Obj *objPtr) /* Regexp object with internal rep to free. */ { - TclRegexp *regexpRepPtr = objPtr->internalRep.otherValuePtr; + TclRegexp *regexpRepPtr = objPtr->internalRep.twoPtrValue.ptr1; /* * If this is the last reference to the regexp, free it. @@ -783,10 +783,10 @@ DupRegexpInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { - TclRegexp *regexpPtr = srcPtr->internalRep.otherValuePtr; + TclRegexp *regexpPtr = srcPtr->internalRep.twoPtrValue.ptr1; regexpPtr->refCount++; - copyPtr->internalRep.otherValuePtr = srcPtr->internalRep.otherValuePtr; + copyPtr->internalRep.twoPtrValue.ptr1 = srcPtr->internalRep.twoPtrValue.ptr1; copyPtr->typePtr = &tclRegexpType; } diff --git a/generic/tclResult.c b/generic/tclResult.c index ad45c41..a22f83f 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -34,7 +34,7 @@ static void ResetObjResult(Interp *iPtr); * then back up to the result or the error that was previously in progress. */ -typedef struct InterpState { +typedef struct { int status; /* return code status */ int flags; /* Each remaining field saves the */ int returnLevel; /* corresponding field of the Interp */ @@ -210,106 +210,6 @@ Tcl_DiscardInterpState( /* *---------------------------------------------------------------------- * - * Tcl_SaveResult -- - * - * Takes a snapshot of the current result state of the interpreter. The - * snapshot can be restored at any point by Tcl_RestoreResult. Note that - * this routine does not preserve the errorCode, errorInfo, or flags - * fields so it should not be used if an error is in progress. - * - * Once a snapshot is saved, it must be restored by calling - * Tcl_RestoreResult, or discarded by calling Tcl_DiscardResult. - * - * Results: - * None. - * - * Side effects: - * Resets the interpreter result. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_SaveResult( - Tcl_Interp *interp, /* Interpreter to save. */ - Tcl_SavedResult *statePtr) /* Pointer to state structure. */ -{ - Interp *iPtr = (Interp *) interp; - - /* - * Move the result object into the save state. Note that we don't need to - * change its refcount because we're moving it, not adding a new - * reference. Put an empty object into the interpreter. - */ - - statePtr->objResultPtr = iPtr->objResultPtr; - iPtr->objResultPtr = Tcl_NewObj(); - Tcl_IncrRefCount(iPtr->objResultPtr); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_RestoreResult -- - * - * Restores the state of the interpreter to a snapshot taken by - * Tcl_SaveResult. After this call, the token for the interpreter state - * is no longer valid. - * - * Results: - * None. - * - * Side effects: - * Restores the interpreter result. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_RestoreResult( - Tcl_Interp *interp, /* Interpreter being restored. */ - Tcl_SavedResult *statePtr) /* State returned by Tcl_SaveResult. */ -{ - Interp *iPtr = (Interp *) interp; - - Tcl_ResetResult(interp); - - /* - * Restore the object result. - */ - - Tcl_DecrRefCount(iPtr->objResultPtr); - iPtr->objResultPtr = statePtr->objResultPtr; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_DiscardResult -- - * - * Frees the memory associated with an interpreter snapshot taken by - * Tcl_SaveResult. If the snapshot is not restored, this function must be - * called to discard it, or the memory will be lost. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_DiscardResult( - Tcl_SavedResult *statePtr) /* State returned by Tcl_SaveResult. */ -{ - TclDecrRefCount(statePtr->objResultPtr); -} - -/* - *---------------------------------------------------------------------- - * * Tcl_SetResult -- * * Arrange for "result" to be the Tcl return value. @@ -1231,7 +1131,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/tclScan.c b/generic/tclScan.c index ef7eedf..c54395d 100644 --- a/generic/tclScan.c +++ b/generic/tclScan.c @@ -28,7 +28,7 @@ * character set. */ -typedef struct CharSet { +typedef struct { int exclude; /* 1 if this is an exclusion set. */ int nchars; Tcl_UniChar *chars; diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index b38f521..73e7c06 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -104,7 +104,7 @@ const Tcl_ObjType tclStringType = { * tcl.h, but do not do that unless you are sure what you're doing! */ -typedef struct String { +typedef struct { int numChars; /* The number of chars in the string. -1 means * this value has not been calculated. >= 0 * means that there is a valid Unicode rep, or @@ -140,9 +140,9 @@ typedef struct String { #define stringAttemptRealloc(ptr, numChars) \ (String *) attemptckrealloc((ptr), (unsigned) STRING_SIZE(numChars) ) #define GET_STRING(objPtr) \ - ((String *) (objPtr)->internalRep.otherValuePtr) + ((String *) (objPtr)->internalRep.twoPtrValue.ptr1) #define SET_STRING(objPtr, stringPtr) \ - ((objPtr)->internalRep.otherValuePtr = (void *) (stringPtr)) + ((objPtr)->internalRep.twoPtrValue.ptr1 = (void *) (stringPtr)) /* * TCL STRING GROWTH ALGORITHM @@ -2043,7 +2043,7 @@ Tcl_AppendFormatToObj( const char *bytes; if (useShort) { - pure = Tcl_NewIntObj((int) s); + pure = Tcl_NewLongObj((long) s); } else if (useWide) { pure = Tcl_NewWideIntObj(w); } else if (useBig) { @@ -2517,7 +2517,7 @@ AppendPrintfToObjVA( break; case '*': lastNum = (int) va_arg(argList, int); - Tcl_ListObjAppendElement(NULL, list, Tcl_NewIntObj(lastNum)); + Tcl_ListObjAppendElement(NULL, list, Tcl_NewLongObj(lastNum)); p++; break; case '0': case '1': case '2': case '3': case '4': diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 39d1262..2a10d25 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -25,10 +25,8 @@ #undef Tcl_Alloc #undef Tcl_Free #undef Tcl_Realloc -#undef Tcl_NewBooleanObj #undef Tcl_NewByteArrayObj #undef Tcl_NewDoubleObj -#undef Tcl_NewIntObj #undef Tcl_NewListObj #undef Tcl_NewLongObj #undef Tcl_NewObj @@ -42,6 +40,7 @@ #undef TclpGetPid #undef TclSockMinimumBuffers #undef TclPkgProvide +#undef Tcl_SetIntObj #define TclPkgProvide pkgProvide static int TclPkgProvide( @@ -66,14 +65,6 @@ static int TclPkgProvide( return TCL_ERROR; } -#if defined(_WIN32) || defined(__CYGWIN__) -#undef TclWinNToHS -#define TclWinNToHS winNToHS -static unsigned short TclWinNToHS(unsigned short ns) { - return ntohs(ns); -} -#endif - #ifdef __WIN32__ # define TclUnixWaitForFile 0 # define TclUnixCopyFile 0 @@ -310,22 +301,22 @@ static const TclIntStubs tclIntStubs = { TclUpdateReturnInfo, /* 109 */ TclSockMinimumBuffers, /* 110 */ Tcl_AddInterpResolvers, /* 111 */ - Tcl_AppendExportList, /* 112 */ - Tcl_CreateNamespace, /* 113 */ - Tcl_DeleteNamespace, /* 114 */ - Tcl_Export, /* 115 */ - Tcl_FindCommand, /* 116 */ - Tcl_FindNamespace, /* 117 */ + 0, /* 112 */ + 0, /* 113 */ + 0, /* 114 */ + 0, /* 115 */ + 0, /* 116 */ + 0, /* 117 */ Tcl_GetInterpResolvers, /* 118 */ Tcl_GetNamespaceResolvers, /* 119 */ Tcl_FindNamespaceVar, /* 120 */ - Tcl_ForgetImport, /* 121 */ - Tcl_GetCommandFromObj, /* 122 */ - Tcl_GetCommandFullName, /* 123 */ - Tcl_GetCurrentNamespace, /* 124 */ - Tcl_GetGlobalNamespace, /* 125 */ + 0, /* 121 */ + 0, /* 122 */ + 0, /* 123 */ + 0, /* 124 */ + 0, /* 125 */ Tcl_GetVariableFullName, /* 126 */ - Tcl_Import, /* 127 */ + 0, /* 127 */ Tcl_PopCallFrame, /* 128 */ Tcl_PushCallFrame, /* 129 */ Tcl_RemoveInterpResolvers, /* 130 */ @@ -494,7 +485,7 @@ static const TclIntPlatStubs tclIntPlatStubs = { TclWinGetSockOpt, /* 3 */ TclWinGetTclInstance, /* 4 */ TclUnixWaitForFile, /* 5 */ - TclWinNToHS, /* 6 */ + 0, /* 6 */ TclWinSetSockOpt, /* 7 */ TclpGetPid, /* 8 */ TclWinGetPlatformId, /* 9 */ @@ -684,7 +675,7 @@ const TclStubs tclStubs = { Tcl_DbDecrRefCount, /* 19 */ Tcl_DbIncrRefCount, /* 20 */ Tcl_DbIsShared, /* 21 */ - Tcl_DbNewBooleanObj, /* 22 */ + 0, /* 22 */ Tcl_DbNewByteArrayObj, /* 23 */ Tcl_DbNewDoubleObj, /* 24 */ Tcl_DbNewListObj, /* 25 */ @@ -698,7 +689,7 @@ const TclStubs tclStubs = { Tcl_GetByteArrayFromObj, /* 33 */ Tcl_GetDouble, /* 34 */ Tcl_GetDoubleFromObj, /* 35 */ - Tcl_GetIndexFromObj, /* 36 */ + 0, /* 36 */ Tcl_GetInt, /* 37 */ Tcl_GetIntFromObj, /* 38 */ Tcl_GetLongFromObj, /* 39 */ @@ -711,25 +702,25 @@ const TclStubs tclStubs = { Tcl_ListObjIndex, /* 46 */ Tcl_ListObjLength, /* 47 */ Tcl_ListObjReplace, /* 48 */ - Tcl_NewBooleanObj, /* 49 */ + 0, /* 49 */ Tcl_NewByteArrayObj, /* 50 */ Tcl_NewDoubleObj, /* 51 */ - Tcl_NewIntObj, /* 52 */ + 0, /* 52 */ Tcl_NewListObj, /* 53 */ Tcl_NewLongObj, /* 54 */ Tcl_NewObj, /* 55 */ Tcl_NewStringObj, /* 56 */ - Tcl_SetBooleanObj, /* 57 */ + 0, /* 57 */ Tcl_SetByteArrayLength, /* 58 */ Tcl_SetByteArrayObj, /* 59 */ Tcl_SetDoubleObj, /* 60 */ - Tcl_SetIntObj, /* 61 */ + 0, /* 61 */ Tcl_SetListObj, /* 62 */ Tcl_SetLongObj, /* 63 */ Tcl_SetObjLength, /* 64 */ Tcl_SetStringObj, /* 65 */ - Tcl_AddErrorInfo, /* 66 */ - Tcl_AddObjErrorInfo, /* 67 */ + 0, /* 66 */ + 0, /* 67 */ Tcl_AllowExceptions, /* 68 */ Tcl_AppendElement, /* 69 */ Tcl_AppendResult, /* 70 */ @@ -791,9 +782,9 @@ const TclStubs tclStubs = { Tcl_Eof, /* 126 */ Tcl_ErrnoId, /* 127 */ Tcl_ErrnoMsg, /* 128 */ - Tcl_Eval, /* 129 */ + 0, /* 129 */ 0, /* 130 */ - Tcl_EvalObj, /* 131 */ + 0, /* 131 */ Tcl_EventuallyFree, /* 132 */ Tcl_Exit, /* 133 */ Tcl_ExposeCommand, /* 134 */ @@ -845,7 +836,7 @@ const TclStubs tclStubs = { Tcl_GetSlave, /* 172 */ Tcl_GetStdChannel, /* 173 */ Tcl_GetStringResult, /* 174 */ - Tcl_GetVar, /* 175 */ + 0, /* 175 */ Tcl_GetVar2, /* 176 */ 0, /* 177 */ 0, /* 178 */ @@ -907,7 +898,7 @@ const TclStubs tclStubs = { Tcl_SetObjErrorCode, /* 234 */ Tcl_SetObjResult, /* 235 */ Tcl_SetStdChannel, /* 236 */ - Tcl_SetVar, /* 237 */ + 0, /* 237 */ Tcl_SetVar2, /* 238 */ Tcl_SignalId, /* 239 */ Tcl_SignalMsg, /* 240 */ @@ -917,21 +908,21 @@ const TclStubs tclStubs = { Tcl_StaticPackage, /* 244 */ Tcl_StringMatch, /* 245 */ 0, /* 246 */ - Tcl_TraceVar, /* 247 */ + 0, /* 247 */ Tcl_TraceVar2, /* 248 */ Tcl_TranslateFileName, /* 249 */ Tcl_Ungets, /* 250 */ Tcl_UnlinkVar, /* 251 */ Tcl_UnregisterChannel, /* 252 */ - Tcl_UnsetVar, /* 253 */ + 0, /* 253 */ Tcl_UnsetVar2, /* 254 */ - Tcl_UntraceVar, /* 255 */ + 0, /* 255 */ Tcl_UntraceVar2, /* 256 */ Tcl_UpdateLinkedVar, /* 257 */ - Tcl_UpVar, /* 258 */ + 0, /* 258 */ Tcl_UpVar2, /* 259 */ 0, /* 260 */ - Tcl_VarTraceInfo, /* 261 */ + 0, /* 261 */ Tcl_VarTraceInfo2, /* 262 */ Tcl_Write, /* 263 */ Tcl_WrongNumArgs, /* 264 */ @@ -941,10 +932,10 @@ const TclStubs tclStubs = { 0, /* 268 */ Tcl_HashStats, /* 269 */ Tcl_ParseVar, /* 270 */ - Tcl_PkgPresent, /* 271 */ + 0, /* 271 */ Tcl_PkgPresentEx, /* 272 */ TclPkgProvide, /* 273 */ - Tcl_PkgRequire, /* 274 */ + 0, /* 274 */ 0, /* 275 */ 0, /* 276 */ Tcl_WaitPid, /* 277 */ @@ -960,7 +951,7 @@ const TclStubs tclStubs = { Tcl_CreateEncoding, /* 287 */ Tcl_CreateThreadExitHandler, /* 288 */ Tcl_DeleteThreadExitHandler, /* 289 */ - Tcl_DiscardResult, /* 290 */ + 0, /* 290 */ Tcl_EvalEx, /* 291 */ Tcl_EvalObjv, /* 292 */ Tcl_EvalObjEx, /* 293 */ @@ -984,8 +975,8 @@ const TclStubs tclStubs = { Tcl_ConditionWait, /* 311 */ Tcl_NumUtfChars, /* 312 */ Tcl_ReadChars, /* 313 */ - Tcl_RestoreResult, /* 314 */ - Tcl_SaveResult, /* 315 */ + 0, /* 314 */ + 0, /* 315 */ Tcl_SetSystemEncoding, /* 316 */ Tcl_SetVar2Ex, /* 317 */ Tcl_ThreadAlert, /* 318 */ diff --git a/generic/tclStubLib.c b/generic/tclStubLib.c index 720d9ef..cadb7b9 100644 --- a/generic/tclStubLib.c +++ b/generic/tclStubLib.c @@ -23,39 +23,16 @@ 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) -{ - return (c >= '0' && c <= '9'); -} +#define ISDIGIT(c) (((unsigned)((c)-'0')) <= 9) /* *---------------------------------------------------------------------- * - * TclInitStubs -- + * Tcl_InitStubs -- * * Tries to initialise the stub table pointers and ensures that the * correct version of Tcl is loaded. @@ -71,16 +48,17 @@ static int isDigit(const int c) */ #undef Tcl_InitStubs MODULE_SCOPE const char * -TclInitStubs( +Tcl_InitStubs( Tcl_Interp *interp, const char *version, int exact, const char *tclversion, int magic) { + Interp *iPtr = (Interp *) interp; const char *actualVersion = NULL; ClientData pkgData = NULL; - const TclStubs *stubsPtr; + const TclStubs *stubsPtr = iPtr->stubTable; /* * We can't optimize this check by caching tclStubsPtr because that @@ -88,8 +66,9 @@ TclInitStubs( * times. [Bug 615304] */ - stubsPtr = HasStubSupport(interp, tclversion, magic); - if (!stubsPtr) { + if (!stubsPtr || (stubsPtr->magic != TCL_STUB_MAGIC)) { + iPtr->legacyResult = "interpreter uses an incompatible stubs mechanism"; + iPtr->legacyFreeProc = 0; /* TCL_STATIC */ return NULL; } @@ -97,12 +76,12 @@ TclInitStubs( if (actualVersion == NULL) { return NULL; } - if (exact) { + if (exact&1) { const char *p = version; int count = 0; while (*p) { - count += !isDigit(*p++); + count += !ISDIGIT(*p++); } if (count == 1) { const char *q = actualVersion; @@ -111,7 +90,7 @@ TclInitStubs( while (*p && (*p == *q)) { p++; q++; } - if (*p || isDigit(*q)) { + if (*p || ISDIGIT(*q)) { /* Construct error message */ stubsPtr->tcl_PkgRequireEx(interp, "Tcl", version, 1, NULL); return NULL; @@ -123,7 +102,14 @@ TclInitStubs( } } } - tclStubsPtr = (TclStubs *)pkgData; + + if (stubsPtr->reserved77) { + /* We are running Tcl 8. Do some additional checks here. */ + tclStubsPtr = (TclStubs *)pkgData; + } else { + /* We are running Tcl 9. Do some additional checks here. */ + tclStubsPtr = stubsPtr; + } if (tclStubsPtr->hooks) { tclPlatStubsPtr = tclStubsPtr->hooks->tclPlatStubs; diff --git a/generic/tclTest.c b/generic/tclTest.c index 9b958dd..8caf493 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -90,7 +90,7 @@ static Tcl_Trace cmdTrace; * TestdelCmd: */ -typedef struct DelCmd { +typedef struct { Tcl_Interp *interp; /* Interpreter in which command exists. */ char *deleteCmd; /* Script to execute when command is deleted. * Malloc'ed. */ @@ -101,7 +101,7 @@ typedef struct DelCmd { * command. */ -typedef struct TclEncoding { +typedef struct { Tcl_Interp *interp; char *toUtfCmd; char *fromUtfCmd; @@ -117,7 +117,7 @@ static int exitMainLoop = 0; * Event structure used in testing the event queue management procedures. */ -typedef struct TestEvent { +typedef struct { Tcl_Event header; /* Header common to all events */ Tcl_Interp *interp; /* Interpreter that will handle the event */ Tcl_Obj *command; /* Command to evaluate when the event occurs */ @@ -521,7 +521,7 @@ Tcltest_Init( } /* TIP #268: Full patchlevel instead of just major.minor */ - if (Tcl_PkgProvide(interp, "Tcltest", TCL_PATCH_LEVEL) == TCL_ERROR) { + if (Tcl_PkgProvideEx(interp, "Tcltest", TCL_PATCH_LEVEL, NULL) == TCL_ERROR) { return TCL_ERROR; } @@ -680,8 +680,8 @@ Tcltest_Init( if (Tcl_ListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) { return TCL_ERROR; } - if (objc && (Tcl_GetIndexFromObj(NULL, objv[0], specialOptions, NULL, - TCL_EXACT, &index) == TCL_OK)) { + if (objc && (Tcl_GetIndexFromObjStruct(NULL, objv[0], specialOptions, + sizeof(char *), NULL, TCL_EXACT, &index) == TCL_OK)) { switch (index) { case 0: return TCL_ERROR; @@ -771,7 +771,7 @@ TestasyncCmd( if (argc < 2) { wrongNumArgs: - Tcl_SetResult(interp, "wrong # args", TCL_STATIC); + Tcl_AppendResult(interp, "wrong # args", NULL); return TCL_ERROR; } if (strcmp(argv[1], "create") == 0) { @@ -789,7 +789,7 @@ TestasyncCmd( asyncPtr->nextPtr = firstHandler; firstHandler = asyncPtr; Tcl_MutexUnlock(&asyncTestMutex); - Tcl_SetObjResult(interp, Tcl_NewIntObj(asyncPtr->id)); + Tcl_SetObjResult(interp, Tcl_NewLongObj(asyncPtr->id)); } else if (strcmp(argv[1], "delete") == 0) { if (argc == 2) { Tcl_MutexLock(&asyncTestMutex); @@ -861,7 +861,7 @@ TestasyncCmd( if (Tcl_CreateThread(&threadID, AsyncThreadProc, INT2PTR(id), TCL_THREAD_STACK_DEFAULT, TCL_THREAD_NOFLAGS) != TCL_OK) { - Tcl_SetResult(interp, "can't create thread", TCL_STATIC); + Tcl_AppendResult(interp, "can't create thread", NULL); Tcl_MutexUnlock(&asyncTestMutex); return TCL_ERROR; } @@ -885,7 +885,7 @@ TestasyncCmd( static int AsyncHandlerProc( - ClientData clientData, /* If of TestAsyncHandler structure. + ClientData clientData, /* If of TestAsyncHandler structure. * in global list. */ Tcl_Interp *interp, /* Interpreter in which command was * executed, or NULL. */ @@ -915,7 +915,7 @@ AsyncHandlerProc( listArgv[3] = NULL; cmd = Tcl_Merge(3, listArgv); if (interp != NULL) { - code = Tcl_Eval(interp, cmd); + code = Tcl_EvalEx(interp, cmd, -1, 0); } else { /* * this should not happen, but by definition of how async handlers are @@ -1008,7 +1008,7 @@ TestcmdinfoCmd( Tcl_DStringResult(interp, &delString); } else if (strcmp(argv[1], "get") == 0) { if (Tcl_GetCommandInfo(interp, argv[2], &info) ==0) { - Tcl_SetResult(interp, "??", TCL_STATIC); + Tcl_AppendResult(interp, "??", NULL); return TCL_OK; } if (info.proc == CmdProc1) { @@ -1043,9 +1043,9 @@ TestcmdinfoCmd( info.deleteProc = CmdDelProc2; info.deleteData = (ClientData) "new_delete_data"; if (Tcl_SetCommandInfo(interp, argv[2], &info) == 0) { - Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); + Tcl_SetObjResult(interp, Tcl_NewLongObj(0)); } else { - Tcl_SetObjResult(interp, Tcl_NewIntObj(1)); + Tcl_SetObjResult(interp, Tcl_NewLongObj(1)); } } else { Tcl_AppendResult(interp, "bad option \"", argv[1], @@ -1135,7 +1135,7 @@ TestcmdtokenCmd( token = Tcl_CreateCommand(interp, argv[2], CmdProc1, (ClientData) "original", NULL); sprintf(buf, "%p", (void *)token); - Tcl_SetResult(interp, buf, TCL_VOLATILE); + Tcl_AppendResult(interp, buf, NULL); } else if (strcmp(argv[1], "name") == 0) { Tcl_Obj *objPtr; @@ -1198,7 +1198,7 @@ TestcmdtraceCmd( if (strcmp(argv[1], "tracetest") == 0) { Tcl_DStringInit(&buffer); cmdTrace = Tcl_CreateTrace(interp, 50000, CmdTraceProc, &buffer); - result = Tcl_Eval(interp, argv[2]); + result = Tcl_EvalEx(interp, argv[2], -1, 0); if (result == TCL_OK) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), NULL); @@ -1214,13 +1214,13 @@ TestcmdtraceCmd( */ cmdTrace = Tcl_CreateTrace(interp, 50000, CmdTraceDeleteProc, NULL); - Tcl_Eval(interp, argv[2]); + Tcl_EvalEx(interp, argv[2], -1, 0); } else if (strcmp(argv[1], "leveltest") == 0) { Interp *iPtr = (Interp *) interp; Tcl_DStringInit(&buffer); cmdTrace = Tcl_CreateTrace(interp, iPtr->numLevels + 4, CmdTraceProc, &buffer); - result = Tcl_Eval(interp, argv[2]); + result = Tcl_EvalEx(interp, argv[2], -1, 0); if (result == TCL_OK) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), NULL); @@ -1238,10 +1238,10 @@ TestcmdtraceCmd( cmdTrace = Tcl_CreateObjTrace(interp, 50000, TCL_ALLOW_INLINE_COMPILATION, ObjTraceProc, (ClientData) &deleteCalled, ObjTraceDeleteProc); - result = Tcl_Eval(interp, argv[2]); + result = Tcl_EvalEx(interp, argv[2], -1, 0); Tcl_DeleteTrace(interp, cmdTrace); if (!deleteCalled) { - Tcl_SetResult(interp, "Delete wasn't called", TCL_STATIC); + Tcl_AppendResult(interp, "Delete wasn't called", NULL); return TCL_ERROR; } else { return result; @@ -1252,7 +1252,7 @@ TestcmdtraceCmd( Tcl_DStringInit(&buffer); t1 = Tcl_CreateTrace(interp, 1, CmdTraceProc, &buffer); t2 = Tcl_CreateTrace(interp, 50000, CmdTraceProc, &buffer); - result = Tcl_Eval(interp, argv[2]); + result = Tcl_EvalEx(interp, argv[2], -1, 0); if (result == TCL_OK) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), NULL); @@ -1541,7 +1541,7 @@ TestdelCmd( Tcl_Interp *slave; if (argc != 4) { - Tcl_SetResult(interp, "wrong # args", TCL_STATIC); + Tcl_AppendResult(interp, "wrong # args", NULL); return TCL_ERROR; } @@ -1581,7 +1581,7 @@ DelDeleteProc( { DelCmd *dPtr = clientData; - Tcl_Eval(dPtr->interp, dPtr->deleteCmd); + Tcl_EvalEx(dPtr->interp, dPtr->deleteCmd, -1, 0); Tcl_ResetResult(dPtr->interp); ckfree(dPtr->deleteCmd); ckfree(dPtr); @@ -1693,8 +1693,8 @@ TestdoubledigitsObjCmd(ClientData unused, } if (status != TCL_OK || Tcl_GetIntFromObj(interp, objv[2], &ndigits) != TCL_OK - || Tcl_GetIndexFromObj(interp, objv[3], options, "conversion type", - TCL_EXACT, &type) != TCL_OK) { + || Tcl_GetIndexFromObjStruct(interp, objv[3], options, + sizeof(char *), "conversion type", TCL_EXACT, &type) != TCL_OK) { fprintf(stderr, "bad value? %g\n", d); return TCL_ERROR; } @@ -1710,7 +1710,7 @@ TestdoubledigitsObjCmd(ClientData unused, strObj = Tcl_NewStringObj(str, endPtr-str); ckfree(str); retval = Tcl_NewListObj(1, &strObj); - Tcl_ListObjAppendElement(NULL, retval, Tcl_NewIntObj(decpt)); + Tcl_ListObjAppendElement(NULL, retval, Tcl_NewLongObj(decpt)); strObj = Tcl_NewStringObj(signum ? "-" : "+", 1); Tcl_ListObjAppendElement(NULL, retval, strObj); Tcl_SetObjResult(interp, retval); @@ -1746,7 +1746,7 @@ TestdstringCmd( if (argc < 2) { wrongNumArgs: - Tcl_SetResult(interp, "wrong # args", TCL_STATIC); + Tcl_AppendResult(interp, "wrong # args", NULL); return TCL_ERROR; } if (strcmp(argv[1], "append") == 0) { @@ -1782,9 +1782,9 @@ TestdstringCmd( goto wrongNumArgs; } if (strcmp(argv[2], "staticsmall") == 0) { - Tcl_SetResult(interp, "short", TCL_STATIC); + Tcl_AppendResult(interp, "short", NULL); } else if (strcmp(argv[2], "staticlarge") == 0) { - Tcl_SetResult(interp, "first0 first1 first2 first3 first4 first5 first6 first7 first8 first9\nsecond0 second1 second2 second3 second4 second5 second6 second7 second8 second9\nthird0 third1 third2 third3 third4 third5 third6 third7 third8 third9\nfourth0 fourth1 fourth2 fourth3 fourth4 fourth5 fourth6 fourth7 fourth8 fourth9\nfifth0 fifth1 fifth2 fifth3 fifth4 fifth5 fifth6 fifth7 fifth8 fifth9\nsixth0 sixth1 sixth2 sixth3 sixth4 sixth5 sixth6 sixth7 sixth8 sixth9\nseventh0 seventh1 seventh2 seventh3 seventh4 seventh5 seventh6 seventh7 seventh8 seventh9\n", TCL_STATIC); + Tcl_AppendResult(interp, "first0 first1 first2 first3 first4 first5 first6 first7 first8 first9\nsecond0 second1 second2 second3 second4 second5 second6 second7 second8 second9\nthird0 third1 third2 third3 third4 third5 third6 third7 third8 third9\nfourth0 fourth1 fourth2 fourth3 fourth4 fourth5 fourth6 fourth7 fourth8 fourth9\nfifth0 fifth1 fifth2 fifth3 fifth4 fifth5 fifth6 fifth7 fifth8 fifth9\nsixth0 sixth1 sixth2 sixth3 sixth4 sixth5 sixth6 sixth7 sixth8 sixth9\nseventh0 seventh1 seventh2 seventh3 seventh4 seventh5 seventh6 seventh7 seventh8 seventh9\n", NULL); } else if (strcmp(argv[2], "free") == 0) { char *s = ckalloc(100); strcpy(s, "This is a malloc-ed string"); @@ -1805,7 +1805,7 @@ TestdstringCmd( if (argc != 2) { goto wrongNumArgs; } - Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_DStringLength(&dstring))); + Tcl_SetObjResult(interp, Tcl_NewLongObj(Tcl_DStringLength(&dstring))); } else if (strcmp(argv[1], "result") == 0) { if (argc != 2) { goto wrongNumArgs; @@ -1880,8 +1880,8 @@ TestencodingObjCmd( ENC_CREATE, ENC_DELETE }; - if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0, - &index) != TCL_OK) { + if (Tcl_GetIndexFromObjStruct(interp, objv[1], optionStrings, + sizeof(char *), "option", 0, &index) != TCL_OK) { return TCL_ERROR; } @@ -2140,8 +2140,8 @@ TesteventObjCmd( Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg ...?"); return TCL_ERROR; } - if (Tcl_GetIndexFromObj(interp, objv[1], subcommands, "subcommand", - TCL_EXACT, &subCmdIndex) != TCL_OK) { + if (Tcl_GetIndexFromObjStruct(interp, objv[1], subcommands, + sizeof(char *), "subcommand", TCL_EXACT, &subCmdIndex) != TCL_OK) { return TCL_ERROR; } switch (subCmdIndex) { @@ -2150,8 +2150,8 @@ TesteventObjCmd( Tcl_WrongNumArgs(interp, 2, objv, "name position script"); return TCL_ERROR; } - if (Tcl_GetIndexFromObj(interp, objv[3], positions, - "position specifier", TCL_EXACT, &posIndex) != TCL_OK) { + if (Tcl_GetIndexFromObjStruct(interp, objv[3], positions, + sizeof(char *), "position specifier", TCL_EXACT, &posIndex) != TCL_OK) { return TCL_ERROR; } ev = ckalloc(sizeof(TestEvent)); @@ -2384,7 +2384,7 @@ TestexprlongCmd( " expression\"", NULL); return TCL_ERROR; } - Tcl_SetResult(interp, "This is a result", TCL_STATIC); + Tcl_AppendResult(interp, "This is a result", NULL); result = Tcl_ExprLong(interp, argv[1], &exprResult); if (result != TCL_OK) { return result; @@ -2426,7 +2426,7 @@ TestexprlongobjCmd( Tcl_WrongNumArgs(interp, 1, objv, "expression"); return TCL_ERROR; } - Tcl_SetResult(interp, "This is a result", TCL_STATIC); + Tcl_AppendResult(interp, "This is a result", NULL); result = Tcl_ExprLongObj(interp, objv[1], &exprResult); if (result != TCL_OK) { return result; @@ -2469,7 +2469,7 @@ TestexprdoubleCmd( " expression\"", NULL); return TCL_ERROR; } - Tcl_SetResult(interp, "This is a result", TCL_STATIC); + Tcl_AppendResult(interp, "This is a result", NULL); result = Tcl_ExprDouble(interp, argv[1], &exprResult); if (result != TCL_OK) { return result; @@ -2512,7 +2512,7 @@ TestexprdoubleobjCmd( Tcl_WrongNumArgs(interp, 1, objv, "expression"); return TCL_ERROR; } - Tcl_SetResult(interp, "This is a result", TCL_STATIC); + Tcl_AppendResult(interp, "This is a result", NULL); result = Tcl_ExprDoubleObj(interp, objv[1], &exprResult); if (result != TCL_OK) { return result; @@ -3254,8 +3254,8 @@ TestlocaleCmd( return TCL_ERROR; } - if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0, - &index) != TCL_OK) { + if (Tcl_GetIndexFromObjStruct(interp, objv[1], optionStrings, + sizeof(char *), "option", 0, &index) != TCL_OK) { return TCL_ERROR; } @@ -3452,7 +3452,7 @@ PrintParse( Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewStringObj(parsePtr->commandStart, parsePtr->commandSize)); Tcl_ListObjAppendElement(NULL, objPtr, - Tcl_NewIntObj(parsePtr->numWords)); + Tcl_NewLongObj(parsePtr->numWords)); for (i = 0; i < parsePtr->numTokens; i++) { tokenPtr = &parsePtr->tokenPtr[i]; switch (tokenPtr->type) { @@ -3492,7 +3492,7 @@ PrintParse( Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewStringObj(tokenPtr->start, tokenPtr->size)); Tcl_ListObjAppendElement(NULL, objPtr, - Tcl_NewIntObj(tokenPtr->numComponents)); + Tcl_NewLongObj(tokenPtr->numComponents)); } Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewStringObj(parsePtr->commandStart + parsePtr->commandSize, @@ -3662,8 +3662,8 @@ TestregexpObjCmd( if (name[0] != '-') { break; } - if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", TCL_EXACT, - &index) != TCL_OK) { + if (Tcl_GetIndexFromObjStruct(interp, objv[i], options, + sizeof(char *), "switch", TCL_EXACT, &index) != TCL_OK) { return TCL_ERROR; } switch ((enum options) index) { @@ -3738,7 +3738,7 @@ TestregexpObjCmd( * value 0. */ - Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); + Tcl_SetLongObj(Tcl_GetObjResult(interp), 0); if (objc > 2 && (cflags®_EXPECT) && indices) { const char *varName; const char *value; @@ -3834,7 +3834,7 @@ TestregexpObjCmd( * Set the interpreter's object result to an integer object w/ value 1. */ - Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); + Tcl_SetLongObj(Tcl_GetObjResult(interp), 1); return TCL_OK; } @@ -4229,7 +4229,7 @@ TestseterrorcodeCmd( const char **argv) /* Argument strings. */ { if (argc > 6) { - Tcl_SetResult(interp, "too many args", TCL_STATIC); + Tcl_AppendResult(interp, "too many args", NULL); return TCL_ERROR; } Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], argv[4], @@ -4783,7 +4783,7 @@ TestsetCmd( const char *value; if (argc == 2) { - Tcl_SetResult(interp, "before get", TCL_STATIC); + Tcl_AppendResult(interp, "before get", NULL); value = Tcl_GetVar2(interp, argv[1], NULL, flags); if (value == NULL) { return TCL_ERROR; @@ -4791,7 +4791,7 @@ TestsetCmd( Tcl_AppendElement(interp, value); return TCL_OK; } else if (argc == 3) { - Tcl_SetResult(interp, "before set", TCL_STATIC); + Tcl_AppendResult(interp, "before set", NULL); value = Tcl_SetVar2(interp, argv[1], NULL, argv[2], flags); if (value == NULL) { return TCL_ERROR; @@ -4815,7 +4815,7 @@ Testset2Cmd( const char *value; if (argc == 3) { - Tcl_SetResult(interp, "before get", TCL_STATIC); + Tcl_AppendResult(interp, "before get", NULL); value = Tcl_GetVar2(interp, argv[1], argv[2], flags); if (value == NULL) { return TCL_ERROR; @@ -4823,7 +4823,7 @@ Testset2Cmd( Tcl_AppendElement(interp, value); return TCL_OK; } else if (argc == 4) { - Tcl_SetResult(interp, "before set", TCL_STATIC); + Tcl_AppendResult(interp, "before set", NULL); value = Tcl_SetVar2(interp, argv[1], argv[2], argv[3], flags); if (value == NULL) { return TCL_ERROR; @@ -4880,8 +4880,8 @@ TestsaveresultCmd( Tcl_WrongNumArgs(interp, 1, objv, "type script discard"); return TCL_ERROR; } - if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0, - &index) != TCL_OK) { + if (Tcl_GetIndexFromObjStruct(interp, objv[1], optionStrings, + sizeof(char *), "option", 0, &index) != TCL_OK) { return TCL_ERROR; } if (Tcl_GetBooleanFromObj(interp, objv[3], &discard) != TCL_OK) { @@ -4891,7 +4891,7 @@ TestsaveresultCmd( objPtr = NULL; /* Lint. */ switch ((enum options) index) { case RESULT_SMALL: - Tcl_SetResult(interp, "small result", TCL_VOLATILE); + Tcl_AppendResult(interp, "small result", NULL); break; case RESULT_APPEND: Tcl_AppendResult(interp, "append result", NULL); @@ -4917,7 +4917,7 @@ TestsaveresultCmd( if (((enum options) index) == RESULT_OBJECT) { result = Tcl_EvalObjEx(interp, objv[2], 0); } else { - result = Tcl_Eval(interp, Tcl_GetString(objv[2])); + result = Tcl_EvalEx(interp, Tcl_GetString(objv[2]), -1, 0); } if (discard) { @@ -4995,7 +4995,7 @@ TestmainthreadCmd( Tcl_SetObjResult(interp, idObj); return TCL_OK; } else { - Tcl_SetResult(interp, "wrong # args", TCL_STATIC); + Tcl_AppendResult(interp, "wrong # args", NULL); return TCL_ERROR; } } @@ -5796,7 +5796,7 @@ TestWrongNumArgsObjCmd( * Don't use Tcl_WrongNumArgs here, as that is the function * we want to test! */ - Tcl_SetResult(interp, "insufficient arguments", TCL_STATIC); + Tcl_AppendResult(interp, "insufficient arguments", NULL); return TCL_ERROR; } @@ -5813,7 +5813,7 @@ TestWrongNumArgsObjCmd( /* * Asked for more arguments than were given. */ - Tcl_SetResult(interp, "insufficient arguments", TCL_STATIC); + Tcl_AppendResult(interp, "insufficient arguments", NULL); return TCL_ERROR; } @@ -6013,7 +6013,7 @@ TestReport( } Tcl_DStringEndSublist(&ds); Tcl_SaveResult(interp, &savedResult); - Tcl_Eval(interp, Tcl_DStringValue(&ds)); + Tcl_EvalEx(interp, Tcl_DStringValue(&ds), -1, 0); Tcl_DStringFree(&ds); Tcl_RestoreResult(interp, &savedResult); } @@ -6437,7 +6437,7 @@ TestNumUtfCharsCmd( (void) Tcl_GetStringFromObj(objv[1], &len); } len = Tcl_NumUtfChars(Tcl_GetString(objv[1]), len); - Tcl_SetObjResult(interp, Tcl_NewIntObj(len)); + Tcl_SetObjResult(interp, Tcl_NewLongObj(len)); } return TCL_OK; } @@ -6491,7 +6491,7 @@ TestcpuidCmd( return status; } for (i=0 ; i<4 ; ++i) { - regsObjs[i] = Tcl_NewIntObj((int) regs[i]); + regsObjs[i] = Tcl_NewLongObj((int) regs[i]); } Tcl_SetObjResult(interp, Tcl_NewListObj(4, regsObjs)); return TCL_OK; @@ -6532,7 +6532,7 @@ TestHashSystemHashCmd( for (i=0 ; i<limit ; i++) { hPtr = Tcl_CreateHashEntry(&hash, INT2PTR(i), &isNew); if (!isNew) { - Tcl_SetObjResult(interp, Tcl_NewIntObj(i)); + Tcl_SetObjResult(interp, Tcl_NewLongObj(i)); Tcl_AppendToObj(Tcl_GetObjResult(interp)," creation problem",-1); Tcl_DeleteHashTable(&hash); return TCL_ERROR; @@ -6549,13 +6549,13 @@ TestHashSystemHashCmd( for (i=0 ; i<limit ; i++) { hPtr = Tcl_FindHashEntry(&hash, (char *) INT2PTR(i)); if (hPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_NewIntObj(i)); + Tcl_SetObjResult(interp, Tcl_NewLongObj(i)); Tcl_AppendToObj(Tcl_GetObjResult(interp)," lookup problem",-1); Tcl_DeleteHashTable(&hash); return TCL_ERROR; } if (PTR2INT(Tcl_GetHashValue(hPtr)) != i+42) { - Tcl_SetObjResult(interp, Tcl_NewIntObj(i)); + Tcl_SetObjResult(interp, Tcl_NewLongObj(i)); Tcl_AppendToObj(Tcl_GetObjResult(interp)," value problem",-1); Tcl_DeleteHashTable(&hash); return TCL_ERROR; @@ -6586,7 +6586,7 @@ TestgetintCmd( const char **argv) { if (argc < 2) { - Tcl_SetResult(interp, "wrong # args", TCL_STATIC); + Tcl_AppendResult(interp, "wrong # args", NULL); return TCL_ERROR; } else { int val, i, total=0; @@ -6597,7 +6597,7 @@ TestgetintCmd( } total += val; } - Tcl_SetObjResult(interp, Tcl_NewIntObj(total)); + Tcl_SetObjResult(interp, Tcl_NewLongObj(total)); return TCL_OK; } } @@ -6622,18 +6622,18 @@ TestNRELevels( depth = (refDepth - &depth); - levels[0] = Tcl_NewIntObj(depth); - levels[1] = Tcl_NewIntObj(iPtr->numLevels); - levels[2] = Tcl_NewIntObj(iPtr->cmdFramePtr->level); - levels[3] = Tcl_NewIntObj(iPtr->varFramePtr->level); - levels[4] = Tcl_NewIntObj(iPtr->execEnvPtr->execStackPtr->tosPtr + levels[0] = Tcl_NewLongObj(depth); + levels[1] = Tcl_NewLongObj(iPtr->numLevels); + levels[2] = Tcl_NewLongObj(iPtr->cmdFramePtr->level); + levels[3] = Tcl_NewLongObj(iPtr->varFramePtr->level); + levels[4] = Tcl_NewLongObj(iPtr->execEnvPtr->execStackPtr->tosPtr - iPtr->execEnvPtr->execStackPtr->stackWords); while (cbPtr) { i++; cbPtr = cbPtr->nextPtr; } - levels[5] = Tcl_NewIntObj(i); + levels[5] = Tcl_NewLongObj(i); Tcl_SetObjResult(interp, Tcl_NewListObj(6, levels)); return TCL_OK; @@ -6980,8 +6980,8 @@ TestparseargsCmd( if (Tcl_ParseArgsObjv(interp, argTable, &count, objv, &remObjv)!=TCL_OK) { return TCL_ERROR; } - result[0] = Tcl_NewIntObj(foo); - result[1] = Tcl_NewIntObj(count); + result[0] = Tcl_NewLongObj(foo); + result[1] = Tcl_NewLongObj(count); result[2] = Tcl_NewListObj(count, remObjv); Tcl_SetObjResult(interp, Tcl_NewListObj(3, result)); ckfree(remObjv); @@ -7158,8 +7158,8 @@ TestInterpResolverCmd( Tcl_WrongNumArgs(interp, 1, objv, "up|down"); return TCL_ERROR; } - if (Tcl_GetIndexFromObj(interp, objv[1], table, "operation", TCL_EXACT, - &idx) != TCL_OK) { + if (Tcl_GetIndexFromObjStruct(interp, objv[1], table, + sizeof(char *), "operation", TCL_EXACT, &idx) != TCL_OK) { return TCL_ERROR; } switch (idx) { diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index 7494beb..adc6063 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -47,7 +47,7 @@ static int TestobjCmd(ClientData dummy, Tcl_Interp *interp, static int TeststringobjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -typedef struct TestString { +typedef struct { int numChars; int allocated; int maxChars; @@ -172,8 +172,8 @@ TestbignumobjCmd( Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); return TCL_ERROR; } - if (Tcl_GetIndexFromObj(interp, objv[1], subcmds, "option", 0, - &index) != TCL_OK) { + if (Tcl_GetIndexFromObjStruct(interp, objv[1], subcmds, + sizeof(char *), "option", 0, &index) != TCL_OK) { return TCL_ERROR; } string = Tcl_GetString(objv[2]); @@ -346,9 +346,9 @@ TestbooleanobjCmd( */ if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetBooleanObj(varPtr[varIndex], boolValue); + Tcl_SetLongObj(varPtr[varIndex], boolValue!=0); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewBooleanObj(boolValue)); + SetVarToObj(varPtr, varIndex, Tcl_NewLongObj(boolValue!=0)); } Tcl_SetObjResult(interp, varPtr[varIndex]); } else if (strcmp(subCmd, "get") == 0) { @@ -371,9 +371,9 @@ TestbooleanobjCmd( return TCL_ERROR; } if (!Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetBooleanObj(varPtr[varIndex], !boolValue); + Tcl_SetLongObj(varPtr[varIndex], boolValue==0); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewBooleanObj(!boolValue)); + SetVarToObj(varPtr, varIndex, Tcl_NewLongObj(boolValue==0)); } Tcl_SetObjResult(interp, varPtr[varIndex]); } else { @@ -554,13 +554,14 @@ TestindexobjCmd( return TCL_ERROR; } - Tcl_GetIndexFromObj(NULL, objv[1], tablePtr, "token", 0, &index); - indexRep = objv[1]->internalRep.otherValuePtr; + Tcl_GetIndexFromObjStruct(NULL, objv[1], tablePtr, + sizeof(char *), "token", 0, &index); + indexRep = objv[1]->internalRep.twoPtrValue.ptr1; indexRep->index = index2; - result = Tcl_GetIndexFromObj(NULL, objv[1], - tablePtr, "token", 0, &index); + result = Tcl_GetIndexFromObjStruct(NULL, objv[1], + tablePtr, sizeof(char *), "token", 0, &index); if (result == TCL_OK) { - Tcl_SetIntObj(Tcl_GetObjResult(interp), index); + Tcl_SetLongObj(Tcl_GetObjResult(interp), index); } return result; } @@ -592,17 +593,17 @@ TestindexobjCmd( if (objv[3]->typePtr != NULL && !strcmp("index", objv[3]->typePtr->name)) { - indexRep = objv[3]->internalRep.otherValuePtr; + indexRep = objv[3]->internalRep.twoPtrValue.ptr1; if (indexRep->tablePtr == (void *) argv) { TclFreeIntRep(objv[3]); } } - result = Tcl_GetIndexFromObj((setError? interp : NULL), objv[3], - argv, "token", (allowAbbrev? 0 : TCL_EXACT), &index); + result = Tcl_GetIndexFromObjStruct((setError? interp : NULL), objv[3], + argv, sizeof(char *), "token", (allowAbbrev? 0 : TCL_EXACT), &index); ckfree(argv); if (result == TCL_OK) { - Tcl_SetIntObj(Tcl_GetObjResult(interp), index); + Tcl_SetLongObj(Tcl_GetObjResult(interp), index); } return result; } @@ -669,9 +670,9 @@ TestintobjCmd( */ if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetIntObj(varPtr[varIndex], intValue); + Tcl_SetLongObj(varPtr[varIndex], intValue); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(intValue)); + SetVarToObj(varPtr, varIndex, Tcl_NewLongObj(intValue)); } Tcl_SetObjResult(interp, varPtr[varIndex]); } else if (strcmp(subCmd, "set2") == 0) { /* doesn't set result */ @@ -684,9 +685,9 @@ TestintobjCmd( } intValue = i; if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetIntObj(varPtr[varIndex], intValue); + Tcl_SetLongObj(varPtr[varIndex], intValue); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(intValue)); + SetVarToObj(varPtr, varIndex, Tcl_NewLongObj(intValue)); } } else if (strcmp(subCmd, "setlong") == 0) { if (objc != 4) { @@ -780,9 +781,9 @@ TestintobjCmd( return TCL_ERROR; } if (!Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetIntObj(varPtr[varIndex], intValue * 10); + Tcl_SetLongObj(varPtr[varIndex], intValue * 10); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(intValue * 10)); + SetVarToObj(varPtr, varIndex, Tcl_NewLongObj(intValue * 10)); } Tcl_SetObjResult(interp, varPtr[varIndex]); } else if (strcmp(subCmd, "div10") == 0) { @@ -797,9 +798,9 @@ TestintobjCmd( return TCL_ERROR; } if (!Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetIntObj(varPtr[varIndex], intValue / 10); + Tcl_SetLongObj(varPtr[varIndex], intValue / 10); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(intValue / 10)); + SetVarToObj(varPtr, varIndex, Tcl_NewLongObj(intValue / 10)); } Tcl_SetObjResult(interp, varPtr[varIndex]); } else { @@ -864,8 +865,8 @@ TestlistobjCmd( if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { return TCL_ERROR; } - if (Tcl_GetIndexFromObj(interp, objv[1], subcommands, "command", - 0, &cmdIndex) != TCL_OK) { + if (Tcl_GetIndexFromObjStruct(interp, objv[1], subcommands, + sizeof(char *), "command", 0, &cmdIndex) != TCL_OK) { return TCL_ERROR; } switch(cmdIndex) { @@ -963,6 +964,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_NewLongObj(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; @@ -1065,7 +1077,7 @@ TestobjCmd( if (CheckIfVarUnset(interp, varPtr,varIndex)) { return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_NewIntObj(varPtr[varIndex]->refCount)); + Tcl_SetObjResult(interp, Tcl_NewLongObj(varPtr[varIndex]->refCount)); } else if (strcmp(subCmd, "type") == 0) { if (objc != 3) { goto wrongNumArgs; @@ -1150,8 +1162,8 @@ TeststringobjCmd( return TCL_ERROR; } - if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, &option) - != TCL_OK) { + if (Tcl_GetIndexFromObjStruct(interp, objv[1], options, + sizeof(char *), "option", 0, &option) != TCL_OK) { return TCL_ERROR; } switch (option) { @@ -1229,7 +1241,7 @@ TeststringobjCmd( if (objc != 3) { goto wrongNumArgs; } - Tcl_SetIntObj(Tcl_GetObjResult(interp), (varPtr[varIndex] != NULL) + Tcl_SetLongObj(Tcl_GetObjResult(interp), (varPtr[varIndex] != NULL) ? varPtr[varIndex]->length : -1); break; case 5: /* length2 */ @@ -1239,12 +1251,12 @@ TeststringobjCmd( if (varPtr[varIndex] != NULL) { Tcl_ConvertToType(NULL, varPtr[varIndex], Tcl_GetObjType("string")); - strPtr = varPtr[varIndex]->internalRep.otherValuePtr; + strPtr = varPtr[varIndex]->internalRep.twoPtrValue.ptr1; length = (int) strPtr->allocated; } else { length = -1; } - Tcl_SetIntObj(Tcl_GetObjResult(interp), length); + Tcl_SetLongObj(Tcl_GetObjResult(interp), length); break; case 6: /* set */ if (objc != 4) { @@ -1293,12 +1305,12 @@ TeststringobjCmd( if (varPtr[varIndex] != NULL) { Tcl_ConvertToType(NULL, varPtr[varIndex], Tcl_GetObjType("string")); - strPtr = varPtr[varIndex]->internalRep.otherValuePtr; + strPtr = varPtr[varIndex]->internalRep.twoPtrValue.ptr1; length = strPtr->maxChars; } else { length = -1; } - Tcl_SetIntObj(Tcl_GetObjResult(interp), length); + Tcl_SetLongObj(Tcl_GetObjResult(interp), length); break; case 10: /* getunicode */ if (objc != 3) { diff --git a/generic/tclTestProcBodyObj.c b/generic/tclTestProcBodyObj.c index a3f89f6..be510fc 100644 --- a/generic/tclTestProcBodyObj.c +++ b/generic/tclTestProcBodyObj.c @@ -34,7 +34,7 @@ static const char procCommand[] = "proc"; * procs */ -typedef struct CmdTable { +typedef struct { const char *cmdName; /* command name */ Tcl_ObjCmdProc *proc; /* command proc */ int exportIt; /* if 1, export the command */ @@ -143,7 +143,7 @@ RegisterCommand( if (cmdTablePtr->exportIt) { sprintf(buf, "namespace eval %s { namespace export %s }", namespace, cmdTablePtr->cmdName); - if (Tcl_Eval(interp, buf) != TCL_OK) { + if (Tcl_EvalEx(interp, buf, -1, 0) != TCL_OK) { return TCL_ERROR; } } @@ -185,7 +185,7 @@ ProcBodyTestInitInternal( } } - return Tcl_PkgProvide(interp, packageName, packageVersion); + return Tcl_PkgProvideEx(interp, packageName, packageVersion, NULL); } /* diff --git a/generic/tclThreadAlloc.c b/generic/tclThreadAlloc.c index e4261d6..438efc5 100644 --- a/generic/tclThreadAlloc.c +++ b/generic/tclThreadAlloc.c @@ -82,7 +82,7 @@ typedef union Block { * and statistics information. */ -typedef struct Bucket { +typedef struct { Block *firstPtr; /* First block available */ long numFree; /* Number of blocks available */ @@ -573,7 +573,7 @@ TclThreadAllocObj(void) } while (--numMove >= 0) { objPtr = &newObjsPtr[numMove]; - objPtr->internalRep.otherValuePtr = cachePtr->firstObjPtr; + objPtr->internalRep.twoPtrValue.ptr1 = cachePtr->firstObjPtr; cachePtr->firstObjPtr = objPtr; } } @@ -584,7 +584,7 @@ TclThreadAllocObj(void) */ objPtr = cachePtr->firstObjPtr; - cachePtr->firstObjPtr = objPtr->internalRep.otherValuePtr; + cachePtr->firstObjPtr = objPtr->internalRep.twoPtrValue.ptr1; cachePtr->numObjects--; return objPtr; } @@ -621,7 +621,7 @@ TclThreadFreeObj( * Get this thread's list and push on the free Tcl_Obj. */ - objPtr->internalRep.otherValuePtr = cachePtr->firstObjPtr; + objPtr->internalRep.twoPtrValue.ptr1 = cachePtr->firstObjPtr; cachePtr->firstObjPtr = objPtr; cachePtr->numObjects++; @@ -722,16 +722,16 @@ MoveObjs( */ while (--numMove) { - objPtr = objPtr->internalRep.otherValuePtr; + objPtr = objPtr->internalRep.twoPtrValue.ptr1; } - fromPtr->firstObjPtr = objPtr->internalRep.otherValuePtr; + fromPtr->firstObjPtr = objPtr->internalRep.twoPtrValue.ptr1; /* * Move all objects as a block - they are already linked to each other, we * just have to update the first and last. */ - objPtr->internalRep.otherValuePtr = toPtr->firstObjPtr; + objPtr->internalRep.twoPtrValue.ptr1 = toPtr->firstObjPtr; toPtr->firstObjPtr = fromFirstObjPtr; } diff --git a/generic/tclThreadStorage.c b/generic/tclThreadStorage.c index f24e334..36bf0a5 100644 --- a/generic/tclThreadStorage.c +++ b/generic/tclThreadStorage.c @@ -47,7 +47,7 @@ static struct TSDMaster { * The type of the data held per thread in a system TSD. */ -typedef struct TSDTable { +typedef struct { ClientData *tablePtr; /* The table of Tcl TSDs. */ sig_atomic_t allocated; /* The size of the table in the current * thread. */ diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c index c1828bb..ccf5101 100644 --- a/generic/tclThreadTest.c +++ b/generic/tclThreadTest.c @@ -62,7 +62,7 @@ static ThreadSpecificData *threadList = NULL; */ typedef struct ThreadCtrl { - const char *script; /* The Tcl command this thread should + const char *script; /* The Tcl command this thread should * execute */ int flags; /* Initial value of the "flags" field in the * ThreadSpecificData structure for the new @@ -229,8 +229,8 @@ ThreadObjCmd( Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); return TCL_ERROR; } - if (Tcl_GetIndexFromObj(interp, objv[1], threadOptions, "option", 0, - &option) != TCL_OK) { + if (Tcl_GetIndexFromObjStruct(interp, objv[1], threadOptions, + sizeof(char *), "option", 0, &option) != TCL_OK) { return TCL_ERROR; } @@ -368,7 +368,7 @@ ThreadObjCmd( result = Tcl_JoinThread((Tcl_ThreadId)(size_t)id, &status); if (result == TCL_OK) { - Tcl_SetIntObj(Tcl_GetObjResult(interp), status); + Tcl_SetLongObj(Tcl_GetObjResult(interp), status); } else { char buf[20]; @@ -415,7 +415,7 @@ ThreadObjCmd( Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_NewIntObj( + Tcl_SetObjResult(interp, Tcl_NewLongObj( Tcl_DoOneEvent(TCL_ALL_EVENTS | TCL_DONT_WAIT))); return TCL_OK; } @@ -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; } @@ -614,7 +613,7 @@ NewTestThread( */ Tcl_Preserve(tsdPtr->interp); - result = Tcl_Eval(tsdPtr->interp, threadEvalScript); + result = Tcl_EvalEx(tsdPtr->interp, threadEvalScript, -1, 0); if (result != TCL_OK) { ThreadErrorProc(tsdPtr->interp); } @@ -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/tclTimer.c b/generic/tclTimer.c index 6b17825..c5f11c9 100644 --- a/generic/tclTimer.c +++ b/generic/tclTimer.c @@ -91,7 +91,7 @@ typedef struct IdleHandler { * The structure defined below is used in this file only. */ -typedef struct ThreadSpecificData { +typedef struct { TimerHandler *firstTimerHandlerPtr; /* First event in queue. */ int lastTimerId; /* Timer identifier of most recently created * timer. */ @@ -823,8 +823,8 @@ Tcl_AfterObjCmd( || objv[1]->typePtr == &tclWideIntType #endif || objv[1]->typePtr == &tclBignumType - || (Tcl_GetIndexFromObj(NULL, objv[1], afterSubCmds, "", 0, - &index) != TCL_OK)) { + || (Tcl_GetIndexFromObjStruct(NULL, objv[1], afterSubCmds, + sizeof(char *), "", 0, &index) != TCL_OK)) { index = -1; if (Tcl_GetWideIntFromObj(NULL, objv[1], &ms) != TCL_OK) { const char *arg = Tcl_GetString(objv[1]); 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..bbbbf3c 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -143,7 +143,7 @@ static int TraceVarEx(Tcl_Interp *interp, const char *part1, * trace procs */ -typedef struct StringTraceData { +typedef struct { ClientData clientData; /* Client data from Tcl_CreateTrace */ Tcl_CmdTraceProc *proc; /* Trace function from Tcl_CreateTrace */ } StringTraceData; @@ -155,8 +155,8 @@ typedef struct StringTraceData { #define FOREACH_VAR_TRACE(interp, name, clientData) \ (clientData) = NULL; \ - while (((clientData) = Tcl_VarTraceInfo((interp), (name), 0, \ - TraceVarProc, (clientData))) != NULL) + while (((clientData) = Tcl_VarTraceInfo2((interp), (name), NULL, \ + 0, TraceVarProc, (clientData))) != NULL) #define FOREACH_COMMAND_TRACE(interp, name, clientData) \ (clientData) = NULL; \ @@ -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); } @@ -1485,7 +1485,11 @@ TclCheckExecutionTraces( } iPtr->activeCmdTracePtr = active.nextPtr; if (state) { - Tcl_RestoreInterpState(interp, state); + if (traceCode == TCL_OK) { + (void) Tcl_RestoreInterpState(interp, state); + } else { + Tcl_DiscardInterpState(state); + } } return traceCode; @@ -1845,7 +1849,7 @@ TraceExecutionProc( * Append result code. */ - resultCode = Tcl_NewIntObj(code); + resultCode = Tcl_NewLongObj(code); resultCodeStr = Tcl_GetString(resultCode); Tcl_DStringAppendElement(&cmd, resultCodeStr); Tcl_DecrRefCount(resultCode); @@ -1885,7 +1889,7 @@ TraceExecutionProc( * interpreter. */ - traceCode = Tcl_Eval(interp, Tcl_DStringValue(&cmd)); + traceCode = Tcl_EvalEx(interp, Tcl_DStringValue(&cmd), -1, 0); tcmdPtr->flags &= ~TCL_TRACE_EXEC_IN_PROGRESS; /* @@ -1975,7 +1979,7 @@ TraceVarProc( int rewind = ((Interp *)interp)->execEnvPtr->rewind; /* - * We might call Tcl_Eval() below, and that might evaluate [trace vdelete] + * We might call Tcl_EvalEx() below, and that might evaluate [trace vdelete] * which might try to free tvarPtr. We want to use tvarPtr until the end * of this function, so we use Tcl_Preserve() and Tcl_Release() to be sure * it is not freed while we still need it. @@ -2797,38 +2801,6 @@ DisposeTraceResult( /* *---------------------------------------------------------------------- * - * Tcl_UntraceVar -- - * - * Remove a previously-created trace for a variable. - * - * Results: - * None. - * - * Side effects: - * If there exists a trace for the variable given by varName with the - * given flags, proc, and clientData, then that trace is removed. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_UntraceVar( - Tcl_Interp *interp, /* Interpreter containing variable. */ - const char *varName, /* Name of variable; may end with "(index)" to - * signify an array reference. */ - int flags, /* OR-ed collection of bits describing current - * trace, including any of TCL_TRACE_READS, - * TCL_TRACE_WRITES, TCL_TRACE_UNSETS, - * TCL_GLOBAL_ONLY and TCL_NAMESPACE_ONLY. */ - Tcl_VarTraceProc *proc, /* Function assocated with trace. */ - ClientData clientData) /* Arbitrary argument to pass to proc. */ -{ - Tcl_UntraceVar2(interp, varName, NULL, flags, proc, clientData); -} - -/* - *---------------------------------------------------------------------- - * * Tcl_UntraceVar2 -- * * Remove a previously-created trace for a variable. @@ -2959,46 +2931,6 @@ Tcl_UntraceVar2( /* *---------------------------------------------------------------------- * - * Tcl_VarTraceInfo -- - * - * Return the clientData value associated with a trace on a variable. - * This function can also be used to step through all of the traces on a - * particular variable that have the same trace function. - * - * Results: - * The return value is the clientData value associated with a trace on - * the given variable. Information will only be returned for a trace with - * proc as trace function. If the clientData argument is NULL then the - * first such trace is returned; otherwise, the next relevant one after - * the one given by clientData will be returned. If the variable doesn't - * exist, or if there are no (more) traces for it, then NULL is returned. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -ClientData -Tcl_VarTraceInfo( - Tcl_Interp *interp, /* Interpreter containing variable. */ - const char *varName, /* Name of variable; may end with "(index)" to - * signify an array reference. */ - int flags, /* OR-ed combo or TCL_GLOBAL_ONLY, - * TCL_NAMESPACE_ONLY (can be 0). */ - Tcl_VarTraceProc *proc, /* Function assocated with trace. */ - ClientData prevClientData) /* If non-NULL, gives last value returned by - * this function, so this call will return the - * next trace after that one. If NULL, this - * call will return the first trace. */ -{ - return Tcl_VarTraceInfo2(interp, varName, NULL, flags, proc, - prevClientData); -} - -/* - *---------------------------------------------------------------------- - * * Tcl_VarTraceInfo2 -- * * Same as Tcl_VarTraceInfo, except takes name in two pieces instead of @@ -3069,44 +3001,6 @@ Tcl_VarTraceInfo2( /* *---------------------------------------------------------------------- * - * Tcl_TraceVar -- - * - * Arrange for reads and/or writes to a variable to cause a function to - * be invoked, which can monitor the operations and/or change their - * actions. - * - * Results: - * A standard Tcl return value. - * - * Side effects: - * A trace is set up on the variable given by varName, such that future - * references to the variable will be intermediated by proc. See the - * manual entry for complete details on the calling sequence for proc. - * The variable's flags are updated. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_TraceVar( - Tcl_Interp *interp, /* Interpreter in which variable is to be - * traced. */ - const char *varName, /* Name of variable; may end with "(index)" to - * signify an array reference. */ - int flags, /* OR-ed collection of bits, including any of - * TCL_TRACE_READS, TCL_TRACE_WRITES, - * TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY, and - * TCL_NAMESPACE_ONLY. */ - Tcl_VarTraceProc *proc, /* Function to call when specified ops are - * invoked upon varName. */ - ClientData clientData) /* Arbitrary argument to pass to proc. */ -{ - return Tcl_TraceVar2(interp, varName, NULL, flags, proc, clientData); -} - -/* - *---------------------------------------------------------------------- - * * Tcl_TraceVar2 -- * * Arrange for reads and/or writes to a variable to cause a function to diff --git a/generic/tclUniData.c b/generic/tclUniData.c index 5c88639..946a4a5 100644 --- a/generic/tclUniData.c +++ b/generic/tclUniData.c @@ -624,7 +624,7 @@ static const unsigned char groupMap[] = { 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 15, 15, 15, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 17, 17, 17, 17, 17, 0, 7, 7, 7, 3, 3, - 4, 3, 3, 14, 14, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 3, 0, + 4, 3, 3, 14, 14, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 3, 17, 0, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 85, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 86, 86, 86, 86, 86, 86, @@ -792,114 +792,114 @@ static const unsigned char groupMap[] = { 116, 86, 116, 116, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 3, 3, 3, 85, 3, 3, 3, 4, 15, 86, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 0, 0, 0, 0, 0, - 0, 3, 3, 3, 3, 3, 3, 8, 3, 3, 3, 3, 86, 86, 86, 2, 0, 9, 9, 9, 9, 9, - 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 15, 15, 15, 85, 15, 15, 15, 15, 15, + 0, 3, 3, 3, 3, 3, 3, 8, 3, 3, 3, 3, 86, 86, 86, 17, 0, 9, 9, 9, 9, + 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 15, 15, 15, 85, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, - 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 86, 15, 0, 0, 0, 0, 0, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, + 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 86, 15, 0, 0, 0, 0, + 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 86, 86, 86, 116, 116, 116, 116, + 86, 86, 116, 116, 116, 0, 0, 0, 0, 116, 116, 86, 116, 116, 116, 116, + 116, 116, 86, 86, 86, 0, 0, 0, 0, 14, 0, 0, 0, 3, 3, 9, 9, 9, 9, 9, + 9, 9, 9, 9, 9, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 0, 0, 0, 86, 86, 86, 116, 116, 116, 116, 86, - 86, 116, 116, 116, 0, 0, 0, 0, 116, 116, 86, 116, 116, 116, 116, 116, - 116, 86, 86, 86, 0, 0, 0, 0, 14, 0, 0, 0, 3, 3, 9, 9, 9, 9, 9, 9, 9, - 9, 9, 9, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 15, - 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 116, 116, 116, 116, 116, 116, - 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, 15, 15, 15, - 15, 15, 15, 15, 116, 116, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, - 9, 9, 18, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 0, 0, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 116, 116, 116, + 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, + 15, 15, 15, 15, 15, 15, 15, 116, 116, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, + 9, 9, 9, 9, 9, 9, 18, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 86, 86, 116, 116, 116, - 0, 0, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 116, 86, 116, 86, 86, 86, 86, 86, 86, 86, - 0, 86, 116, 86, 116, 116, 86, 86, 86, 86, 86, 86, 86, 86, 116, 116, - 116, 116, 116, 116, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 0, 0, 86, - 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, - 9, 9, 9, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 3, 3, 3, 85, 3, 3, 3, 3, 3, - 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 86, 86, 86, - 86, 116, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 86, 116, - 86, 86, 86, 86, 86, 116, 86, 116, 116, 116, 116, 116, 86, 116, 116, - 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, - 9, 3, 3, 3, 3, 3, 3, 3, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 86, - 86, 86, 86, 86, 86, 86, 86, 86, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 0, 0, 0, 86, 86, 116, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 116, 86, 86, 86, 86, 116, 116, 86, 86, 116, 86, 116, 116, 15, 15, - 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 86, 116, 86, 86, 116, 116, 116, 86, 116, 86, 86, 86, 116, 116, - 0, 0, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 15, 15, 15, 15, 116, 116, 116, - 116, 116, 116, 116, 116, 86, 86, 86, 86, 86, 86, 86, 86, 116, 116, - 86, 86, 0, 0, 0, 3, 3, 3, 3, 3, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, - 0, 15, 15, 15, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, - 15, 15, 15, 15, 15, 15, 15, 85, 85, 85, 85, 85, 85, 3, 3, 3, 3, 3, - 3, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 86, 86, 86, 3, 86, 86, 86, 86, - 86, 86, 86, 86, 86, 86, 86, 86, 86, 116, 86, 86, 86, 86, 86, 86, 86, - 15, 15, 15, 15, 86, 15, 15, 15, 15, 116, 116, 86, 15, 15, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, + 14, 14, 14, 14, 14, 14, 14, 14, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 86, 86, 116, + 116, 86, 0, 0, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 116, 86, 116, 86, 86, 86, 86, 86, + 86, 86, 0, 86, 116, 86, 116, 116, 86, 86, 86, 86, 86, 86, 86, 86, 116, + 116, 116, 116, 116, 116, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 0, + 0, 86, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, + 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 3, 3, 3, 85, 3, 3, + 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 86, + 86, 86, 86, 116, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 86, 116, 86, 86, 86, 86, 86, 116, 86, 116, 116, 116, 116, 116, 86, + 116, 116, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, + 9, 9, 9, 9, 3, 3, 3, 3, 3, 3, 3, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 86, 86, 86, 86, 86, 86, 86, 86, 86, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 0, 0, 0, 86, 86, 116, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 116, 86, 86, 86, 86, 116, 116, 86, 86, 116, 86, 116, 116, + 15, 15, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 86, 116, 86, 86, 116, 116, 116, 86, 116, 86, 86, 86, + 116, 116, 0, 0, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 15, 15, 15, 15, 116, + 116, 116, 116, 116, 116, 116, 116, 86, 86, 86, 86, 86, 86, 86, 86, + 116, 116, 86, 86, 0, 0, 0, 3, 3, 3, 3, 3, 9, 9, 9, 9, 9, 9, 9, 9, 9, + 9, 0, 0, 0, 15, 15, 15, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 85, 85, 85, 85, 85, 85, 3, 3, 3, + 3, 3, 3, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 86, 86, 86, 3, 86, 86, + 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 116, 86, 86, 86, 86, 86, + 86, 86, 15, 15, 15, 15, 86, 15, 15, 15, 15, 116, 116, 86, 15, 15, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, - 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 85, 85, 85, + 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, - 85, 85, 85, 85, 85, 85, 85, 85, 85, 21, 21, 21, 21, 21, 21, 21, 21, - 21, 21, 21, 21, 21, 85, 119, 21, 21, 21, 120, 21, 21, 21, 21, 21, 21, + 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 21, 21, 21, 21, 21, 21, + 21, 21, 21, 21, 21, 21, 21, 85, 119, 21, 21, 21, 120, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, - 21, 21, 21, 21, 21, 21, 85, 85, 85, 85, 85, 86, 86, 86, 86, 86, 86, - 86, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 86, 86, 86, 86, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, - 24, 23, 24, 23, 24, 23, 24, 23, 24, 21, 21, 21, 21, 21, 121, 21, 21, - 122, 21, 123, 123, 123, 123, 123, 123, 123, 123, 124, 124, 124, 124, - 124, 124, 124, 124, 123, 123, 123, 123, 123, 123, 0, 0, 124, 124, 124, - 124, 124, 124, 0, 0, 123, 123, 123, 123, 123, 123, 123, 123, 124, 124, - 124, 124, 124, 124, 124, 124, 123, 123, 123, 123, 123, 123, 123, 123, - 124, 124, 124, 124, 124, 124, 124, 124, 123, 123, 123, 123, 123, 123, - 0, 0, 124, 124, 124, 124, 124, 124, 0, 0, 21, 123, 21, 123, 21, 123, - 21, 123, 0, 124, 0, 124, 0, 124, 0, 124, 123, 123, 123, 123, 123, 123, - 123, 123, 124, 124, 124, 124, 124, 124, 124, 124, 125, 125, 126, 126, - 126, 126, 127, 127, 128, 128, 129, 129, 130, 130, 0, 0, 123, 123, 123, - 123, 123, 123, 123, 123, 131, 131, 131, 131, 131, 131, 131, 131, 123, - 123, 123, 123, 123, 123, 123, 123, 131, 131, 131, 131, 131, 131, 131, - 131, 123, 123, 123, 123, 123, 123, 123, 123, 131, 131, 131, 131, 131, - 131, 131, 131, 123, 123, 21, 132, 21, 0, 21, 21, 124, 124, 133, 133, - 134, 11, 135, 11, 11, 11, 21, 132, 21, 0, 21, 21, 136, 136, 136, 136, - 134, 11, 11, 11, 123, 123, 21, 21, 0, 0, 21, 21, 124, 124, 137, 137, - 0, 11, 11, 11, 123, 123, 21, 21, 21, 106, 21, 21, 124, 124, 138, 138, - 109, 11, 11, 11, 0, 0, 21, 132, 21, 0, 21, 21, 139, 139, 140, 140, - 134, 11, 11, 0, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 17, 17, 17, 17, 17, - 8, 8, 8, 8, 8, 8, 3, 3, 16, 20, 5, 16, 16, 20, 5, 16, 3, 3, 3, 3, 3, - 3, 3, 3, 141, 142, 17, 17, 17, 17, 17, 2, 3, 3, 3, 3, 3, 3, 3, 3, 3, - 16, 20, 3, 3, 3, 3, 12, 12, 3, 3, 3, 7, 5, 6, 3, 3, 3, 3, 3, 3, 3, - 3, 3, 3, 3, 7, 3, 12, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 2, 17, 17, 17, - 17, 17, 0, 0, 0, 0, 0, 17, 17, 17, 17, 17, 17, 18, 85, 0, 0, 18, 18, - 18, 18, 18, 18, 7, 7, 7, 5, 6, 85, 18, 18, 18, 18, 18, 18, 18, 18, - 18, 18, 7, 7, 7, 5, 6, 0, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, - 85, 85, 0, 0, 0, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, - 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, - 86, 86, 111, 111, 111, 111, 86, 111, 111, 111, 86, 86, 86, 86, 86, - 86, 86, 86, 86, 86, 86, 86, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 14, 14, 100, 14, 14, 14, 14, 100, 14, 14, 21, 100, 100, 100, - 21, 21, 100, 100, 100, 21, 14, 100, 14, 14, 7, 100, 100, 100, 100, - 100, 14, 14, 14, 14, 14, 14, 100, 14, 143, 14, 100, 14, 144, 145, 100, - 100, 14, 21, 100, 100, 146, 100, 21, 15, 15, 15, 15, 21, 14, 14, 21, - 21, 100, 100, 7, 7, 7, 7, 7, 100, 21, 21, 21, 21, 14, 7, 14, 14, 147, - 14, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, - 148, 148, 148, 148, 148, 148, 148, 148, 148, 148, 148, 148, 148, 148, - 148, 148, 149, 149, 149, 149, 149, 149, 149, 149, 149, 149, 149, 149, - 149, 149, 149, 149, 118, 118, 118, 23, 24, 118, 118, 118, 118, 18, - 0, 0, 0, 0, 0, 0, 7, 7, 7, 7, 7, 14, 14, 14, 14, 14, 7, 7, 14, 14, - 14, 14, 7, 14, 14, 7, 14, 14, 7, 14, 14, 14, 14, 14, 14, 14, 7, 14, + 21, 21, 21, 21, 21, 21, 21, 21, 85, 85, 85, 85, 85, 86, 86, 86, 86, + 86, 86, 86, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 86, 86, 86, 86, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, + 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 21, 21, 21, 21, 21, 121, 21, + 21, 122, 21, 123, 123, 123, 123, 123, 123, 123, 123, 124, 124, 124, + 124, 124, 124, 124, 124, 123, 123, 123, 123, 123, 123, 0, 0, 124, 124, + 124, 124, 124, 124, 0, 0, 123, 123, 123, 123, 123, 123, 123, 123, 124, + 124, 124, 124, 124, 124, 124, 124, 123, 123, 123, 123, 123, 123, 123, + 123, 124, 124, 124, 124, 124, 124, 124, 124, 123, 123, 123, 123, 123, + 123, 0, 0, 124, 124, 124, 124, 124, 124, 0, 0, 21, 123, 21, 123, 21, + 123, 21, 123, 0, 124, 0, 124, 0, 124, 0, 124, 123, 123, 123, 123, 123, + 123, 123, 123, 124, 124, 124, 124, 124, 124, 124, 124, 125, 125, 126, + 126, 126, 126, 127, 127, 128, 128, 129, 129, 130, 130, 0, 0, 123, 123, + 123, 123, 123, 123, 123, 123, 131, 131, 131, 131, 131, 131, 131, 131, + 123, 123, 123, 123, 123, 123, 123, 123, 131, 131, 131, 131, 131, 131, + 131, 131, 123, 123, 123, 123, 123, 123, 123, 123, 131, 131, 131, 131, + 131, 131, 131, 131, 123, 123, 21, 132, 21, 0, 21, 21, 124, 124, 133, + 133, 134, 11, 135, 11, 11, 11, 21, 132, 21, 0, 21, 21, 136, 136, 136, + 136, 134, 11, 11, 11, 123, 123, 21, 21, 0, 0, 21, 21, 124, 124, 137, + 137, 0, 11, 11, 11, 123, 123, 21, 21, 21, 106, 21, 21, 124, 124, 138, + 138, 109, 11, 11, 11, 0, 0, 21, 132, 21, 0, 21, 21, 139, 139, 140, + 140, 134, 11, 11, 0, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 17, 17, 17, 17, + 17, 8, 8, 8, 8, 8, 8, 3, 3, 16, 20, 5, 16, 16, 20, 5, 16, 3, 3, 3, + 3, 3, 3, 3, 3, 141, 142, 17, 17, 17, 17, 17, 2, 3, 3, 3, 3, 3, 3, 3, + 3, 3, 16, 20, 3, 3, 3, 3, 12, 12, 3, 3, 3, 7, 5, 6, 3, 3, 3, 3, 3, + 3, 3, 3, 3, 3, 3, 7, 3, 12, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 2, 17, 17, + 17, 17, 17, 0, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 18, 85, 0, 0, + 18, 18, 18, 18, 18, 18, 7, 7, 7, 5, 6, 85, 18, 18, 18, 18, 18, 18, + 18, 18, 18, 18, 7, 7, 7, 5, 6, 0, 85, 85, 85, 85, 85, 85, 85, 85, 85, + 85, 85, 85, 85, 0, 0, 0, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, + 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 86, 86, 86, 86, 86, 86, 86, 86, 86, + 86, 86, 86, 86, 111, 111, 111, 111, 86, 111, 111, 111, 86, 86, 86, + 86, 86, 86, 86, 86, 86, 86, 86, 86, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 14, 14, 100, 14, 14, 14, 14, 100, 14, 14, 21, 100, 100, + 100, 21, 21, 100, 100, 100, 21, 14, 100, 14, 14, 7, 100, 100, 100, + 100, 100, 14, 14, 14, 14, 14, 14, 100, 14, 143, 14, 100, 14, 144, 145, + 100, 100, 14, 21, 100, 100, 146, 100, 21, 15, 15, 15, 15, 21, 14, 14, + 21, 21, 100, 100, 7, 7, 7, 7, 7, 100, 21, 21, 21, 21, 14, 7, 14, 14, + 147, 14, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, + 18, 148, 148, 148, 148, 148, 148, 148, 148, 148, 148, 148, 148, 148, + 148, 148, 148, 149, 149, 149, 149, 149, 149, 149, 149, 149, 149, 149, + 149, 149, 149, 149, 149, 118, 118, 118, 23, 24, 118, 118, 118, 118, + 18, 0, 0, 0, 0, 0, 0, 7, 7, 7, 7, 7, 14, 14, 14, 14, 14, 7, 7, 14, + 14, 14, 14, 7, 14, 14, 7, 14, 14, 7, 14, 14, 14, 14, 14, 14, 14, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, - 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, 7, 14, 14, 7, - 14, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, 7, 14, 14, + 7, 14, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 14, 14, diff --git a/generic/tclUtf.c b/generic/tclUtf.c index 93ab34b..02c5eb8 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -1516,8 +1516,9 @@ Tcl_UniCharIsSpace( if (((Tcl_UniChar) ch) < ((Tcl_UniChar) 0x80)) { return isspace(UCHAR(ch)); /* INTL: ISO space */ - } else if ((Tcl_UniChar) ch == 0x0085 || (Tcl_UniChar) ch == 0x200b - || (Tcl_UniChar) ch == 0x2060 || (Tcl_UniChar) ch == 0xfeff) { + } else if ((Tcl_UniChar) ch == 0x0085 || (Tcl_UniChar) ch == 0x180e + || (Tcl_UniChar) ch == 0x200b || (Tcl_UniChar) ch == 0x2060 + || (Tcl_UniChar) ch == 0xfeff) { return 1; } else { return ((SPACE_BITS >> GetCategory(ch)) & 1); diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 4b69628..bcfdc2a 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. * @@ -871,9 +871,9 @@ Tcl_SplitList( int Tcl_ScanElement( - register const char *src, /* String to convert to list element. */ - register int *flagPtr) /* Where to store information to guide - * Tcl_ConvertCountedElement. */ + const char *src, /* String to convert to list element. */ + int *flagPtr) /* Where to store information to guide + * Tcl_ConvertCountedElement. */ { return Tcl_ScanCountedElement(src, -1, flagPtr); } @@ -908,7 +908,7 @@ Tcl_ScanCountedElement( int *flagPtr) /* Where to store information to guide * Tcl_ConvertElement. */ { - int flags = CONVERT_ANY; + char flags = CONVERT_ANY; int numBytes = TclScanElement(src, length, &flags); *flagPtr = flags; @@ -949,7 +949,7 @@ int TclScanElement( const char *src, /* String to convert to Tcl list element. */ int length, /* Number of bytes in src, or -1. */ - int *flagPtr) /* Where to store information to guide + char *flagPtr) /* Where to store information to guide * Tcl_ConvertElement. */ { const char *p = src; @@ -1234,9 +1234,9 @@ TclScanElement( int Tcl_ConvertElement( - register const char *src, /* Source information for list element. */ - register char *dst, /* Place to put list-ified element. */ - register int flags) /* Flags produced by Tcl_ScanElement. */ + const char *src, /* Source information for list element. */ + char *dst, /* Place to put list-ified element. */ + int flags) /* Flags produced by Tcl_ScanElement. */ { return Tcl_ConvertCountedElement(src, -1, dst, flags); } @@ -1300,9 +1300,9 @@ TclConvertElement( register const char *src, /* Source information for list element. */ int length, /* Number of bytes in src, or -1. */ char *dst, /* Place to put list-ified element. */ - int flags) /* Flags produced by Tcl_ScanElement. */ + char flags) /* Flags produced by Tcl_ScanElement. */ { - int conversion = flags & CONVERT_MASK; + char conversion = flags & CONVERT_MASK; char *p = dst; /* @@ -1481,11 +1481,10 @@ Tcl_Merge( int argc, /* How many strings to merge. */ const char *const *argv) /* Array of string values. */ { -#define LOCAL_SIZE 20 - int localFlags[LOCAL_SIZE], *flagPtr = NULL; +#define LOCAL_SIZE 64 + char localFlags[LOCAL_SIZE]; int i, bytesNeeded = 0; - char *result, *dst; - const int maxFlags = UINT_MAX / sizeof(int); + char *result, *dst, *flagPtr = NULL; /* * Handle empty list case first, so logic of the general case can be @@ -1504,22 +1503,8 @@ Tcl_Merge( if (argc <= LOCAL_SIZE) { flagPtr = localFlags; - } else if (argc > maxFlags) { - /* - * We cannot allocate a large enough flag array to format this list in - * one pass. We could imagine converting this routine to a multi-pass - * implementation, but for sizeof(int) == 4, the limit is a max of - * 2^30 list elements and since each element is at least one byte - * formatted, and requires one byte space between it and the next one, - * that a minimum space requirement of 2^31 bytes, which is already - * INT_MAX. If we tried to format a list of > maxFlags elements, we're - * just going to overflow the size limits on the formatted string - * anyway, so just issue that same panic early. - */ - - Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } else { - flagPtr = ckalloc(argc * sizeof(int)); + flagPtr = ckalloc(argc); } for (i = 0; i < argc; i++) { flagPtr[i] = ( i ? TCL_DONT_QUOTE_HASH : 0 ); @@ -2597,7 +2582,7 @@ Tcl_DStringAppendElement( { char *dst = dsPtr->string + dsPtr->length; int needSpace = TclNeedSpace(dsPtr->string, dst); - int flags = needSpace ? TCL_DONT_QUOTE_HASH : 0; + char flags = needSpace ? TCL_DONT_QUOTE_HASH : 0; int newSize = dsPtr->length + needSpace + TclScanElement(element, -1, &flags); @@ -2827,14 +2812,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. @@ -3141,7 +3128,7 @@ TclPrecTraceProc( if (flags & TCL_TRACE_READS) { - Tcl_SetVar2Ex(interp, name1, name2, Tcl_NewIntObj(*precisionPtr), + Tcl_SetVar2Ex(interp, name1, name2, Tcl_NewLongObj(*precisionPtr), flags & TCL_GLOBAL_ONLY); return NULL; } diff --git a/generic/tclVar.c b/generic/tclVar.c index d8a7141..e153fa4 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, @@ -137,6 +144,30 @@ static const char *isArrayElement = #define HasLocalVars(framePtr) ((framePtr)->isProcCallFrame & FRAME_IS_PROC) /* + * The following structure describes an enumerative search in progress on an + * array variable; this are invoked with options to the "array" command. + */ + +typedef struct ArraySearch { + int id; /* Integer id used to distinguish among + * multiple concurrent searches for the same + * array. */ + struct Var *varPtr; /* Pointer to array variable that's being + * searched. */ + Tcl_HashSearch search; /* Info kept by the hash module about progress + * through the array. */ + Tcl_HashEntry *nextEntry; /* Non-null means this is the next element to + * be enumerated (it's leftover from the + * Tcl_FirstHashEntry call or from an "array + * anymore" command). NULL means must call + * Tcl_NextHashEntry to get value to + * return. */ + struct ArraySearch *nextPtr;/* Next in list of all active searches for + * this variable, or NULL if this is the last + * one. */ +} ArraySearch; + +/* * Forward references to functions defined later in this file: */ @@ -383,11 +414,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 +464,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 +494,14 @@ 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; + if (createPart2) { + Tcl_IncrRefCount(part2Ptr); + } } resPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr, @@ -480,6 +514,12 @@ TclObjLookupVar( return resPtr; } +/* + * When createPart1 is 1, callers must IncrRefCount part1Ptr if they + * plan to DecrRefCount it. + * When createPart2 is 1, callers must IncrRefCount part2Ptr if they + * plan to DecrRefCount it. + */ Var * TclObjLookupVarEx( Tcl_Interp *interp, /* Interpreter to use for lookup. */ @@ -620,7 +660,9 @@ TclObjLookupVarEx( part2 = newPart2 = part1Ptr->internalRep.twoPtrValue.ptr2; if (newPart2) { part2Ptr = Tcl_NewStringObj(newPart2, -1); - Tcl_IncrRefCount(part2Ptr); + if (createPart2) { + Tcl_IncrRefCount(part2Ptr); + } } part1Ptr = part1Ptr->internalRep.twoPtrValue.ptr1; typePtr = part1Ptr->typePtr; @@ -666,7 +708,9 @@ TclObjLookupVarEx( *(newPart2+len2) = '\0'; part2 = newPart2; part2Ptr = Tcl_NewStringObj(newPart2, -1); - Tcl_IncrRefCount(part2Ptr); + if (createPart2) { + Tcl_IncrRefCount(part2Ptr); + } /* * Free the internal rep of the original part1Ptr, now renamed @@ -844,6 +888,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. * *---------------------------------------------------------------------- */ @@ -1072,6 +1117,8 @@ TclLookupSimpleVar( * The variable at arrayPtr may be converted to be an array if * createPart1 is 1. A new hashtable entry may be created if createPart2 * is 1. + * When createElem is 1, callers must incr elNamePtr if they plan + * to decr it. * *---------------------------------------------------------------------- */ @@ -1178,50 +1225,6 @@ TclLookupArrayElement( /* *---------------------------------------------------------------------- * - * Tcl_GetVar -- - * - * Return the value of a Tcl variable as a string. - * - * Results: - * The return value points to the current value of varName as a string. - * If the variable is not defined or can't be read because of a clash in - * array usage then a NULL pointer is returned and an error message is - * left in the interp's result if the TCL_LEAVE_ERR_MSG flag is set. - * Note: the return value is only valid up until the next change to the - * variable; if you depend on the value lasting longer than that, then - * make yourself a private copy. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -const char * -Tcl_GetVar( - Tcl_Interp *interp, /* Command interpreter in which varName is to - * be looked up. */ - const char *varName, /* Name of a variable in interp. */ - int flags) /* OR-ed combination of TCL_GLOBAL_ONLY, - * TCL_NAMESPACE_ONLY or TCL_LEAVE_ERR_MSG - * bits. */ -{ - Tcl_Obj *varNamePtr, *resultPtr; - - varNamePtr = Tcl_NewStringObj(varName, -1); - Tcl_IncrRefCount(varNamePtr); - resultPtr = Tcl_ObjGetVar2(interp, varNamePtr, NULL, flags); - TclDecrRefCount(varNamePtr); - - if (resultPtr == NULL) { - return NULL; - } - return TclGetString(resultPtr); -} - -/* - *---------------------------------------------------------------------- - * * Tcl_GetVar2 -- * * Return the value of a Tcl variable as a string, given a two-part name @@ -1254,15 +1257,12 @@ Tcl_GetVar2( * TCL_NAMESPACE_ONLY and TCL_LEAVE_ERR_MSG * * bits. */ { - Tcl_Obj *resultPtr, *part1Ptr, *part2Ptr; + Tcl_Obj *resultPtr; + 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 { - part2Ptr = NULL; } resultPtr = Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags); @@ -1311,15 +1311,11 @@ 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); @@ -1352,6 +1348,8 @@ Tcl_GetVar2Ex( * the returned reference; if you want to keep a reference to the object * you must increment its ref count yourself. * + * Callers must incr part2Ptr if they plan to decr it. + * *---------------------------------------------------------------------- */ @@ -1525,58 +1523,6 @@ Tcl_SetObjCmd( /* *---------------------------------------------------------------------- * - * Tcl_SetVar -- - * - * Change the value of a variable. - * - * Results: - * Returns a pointer to the malloc'ed string which is the character - * representation of the variable's new value. The caller must not modify - * this string. If the write operation was disallowed then NULL is - * returned; if the TCL_LEAVE_ERR_MSG flag is set, then an explanatory - * message will be left in the interp's result. Note that the returned - * string may not be the same as newValue; this is because variable - * traces may modify the variable's value. - * - * Side effects: - * If varName is defined as a local or global variable in interp, its - * value is changed to newValue. If varName isn't currently defined, then - * a new global variable by that name is created. - * - *---------------------------------------------------------------------- - */ - -const char * -Tcl_SetVar( - Tcl_Interp *interp, /* Command interpreter in which varName is to - * be looked up. */ - const char *varName, /* Name of a variable in interp. */ - const char *newValue, /* New value for varName. */ - int flags) /* Various flags that tell how to set value: - * any of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, - * TCL_APPEND_VALUE, TCL_LIST_ELEMENT, - * TCL_LEAVE_ERR_MSG. */ -{ - Tcl_Obj *valuePtr, *varNamePtr, *varValuePtr; - - varNamePtr = Tcl_NewStringObj(varName, -1); - Tcl_IncrRefCount(varNamePtr); - valuePtr = Tcl_NewStringObj(newValue, -1); - Tcl_IncrRefCount(valuePtr); - - varValuePtr = Tcl_ObjSetVar2(interp, varNamePtr, NULL, valuePtr, flags); - - Tcl_DecrRefCount(varNamePtr); - Tcl_DecrRefCount(valuePtr); - if (varValuePtr == NULL) { - return NULL; - } - return TclGetString(varValuePtr); -} - -/* - *---------------------------------------------------------------------- - * * Tcl_SetVar2 -- * * Given a two-part variable name, which may refer either to a scalar @@ -1615,27 +1561,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); - - varValuePtr = Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, valuePtr, flags); + Tcl_Obj *varValuePtr = Tcl_SetVar2Ex(interp, part1, part2, + Tcl_NewStringObj(newValue, -1), flags); - Tcl_DecrRefCount(part1Ptr); - if (part2Ptr != NULL) { - Tcl_DecrRefCount(part2Ptr); - } - Tcl_DecrRefCount(valuePtr); if (varValuePtr == NULL) { return NULL; } @@ -1694,15 +1622,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 +1660,8 @@ 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. + * Callers must Incr part2Ptr if they plan to Decr it. * *---------------------------------------------------------------------- */ @@ -2024,6 +1951,8 @@ 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. + * Callers must Incr part2Ptr if they plan to Decr it. * *---------------------------------------------------------------------- */ @@ -2049,8 +1978,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 +2035,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)++; @@ -2118,70 +2046,36 @@ TclPtrIncrObjVar( VarHashRefCount(varPtr)--; } if (varValuePtr == NULL) { - varValuePtr = Tcl_NewIntObj(0); + varValuePtr = Tcl_NewLongObj(0); } if (Tcl_IsShared(varValuePtr)) { - duplicated = 1; + /* Copy on write */ varValuePtr = Tcl_DuplicateObj(varValuePtr); - } 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); - } - return newValuePtr; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_UnsetVar -- - * - * Delete a variable, so that it may not be accessed anymore. - * - * Results: - * Returns TCL_OK if the variable was successfully deleted, TCL_ERROR if - * the variable can't be unset. In the event of an error, if the - * TCL_LEAVE_ERR_MSG flag is set then an error message is left in the - * interp's result. - * - * Side effects: - * If varName is defined as a local or global variable in interp, it is - * deleted. - * - *---------------------------------------------------------------------- - */ -int -Tcl_UnsetVar( - Tcl_Interp *interp, /* Command interpreter in which varName is to - * be looked up. */ - const char *varName, /* Name of a variable in interp. May be either - * a scalar name or an array name or an - * element in an array. */ - int flags) /* OR-ed combination of any of - * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY or - * TCL_LEAVE_ERR_MSG. */ -{ - int result; - Tcl_Obj *varNamePtr; - - varNamePtr = Tcl_NewStringObj(varName, -1); - Tcl_IncrRefCount(varNamePtr); - - /* - * Filter to pass through only the flags this interface supports. - */ + if (TCL_OK == TclIncrObj(interp, varValuePtr, incrPtr)) { + return TclPtrSetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, + varValuePtr, flags, index); + } else { + Tcl_DecrRefCount(varValuePtr); + return NULL; + } + } else { + /* Unshared - can Incr in place */ + if (TCL_OK == TclIncrObj(interp, varValuePtr, incrPtr)) { - flags &= (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG); - result = TclObjUnsetVar2(interp, varNamePtr, NULL, flags); + /* + * 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. + */ - Tcl_DecrRefCount(varNamePtr); - return result; + return TclPtrSetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, + varValuePtr, flags, index); + } else { + return NULL; + } + } } /* @@ -2216,13 +2110,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 +2729,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. * *---------------------------------------------------------------------- */ @@ -3734,8 +3626,8 @@ ArrayNamesCmd( * Finish parsing the arguments. */ - if ((objc == 4) && Tcl_GetIndexFromObj(interp, objv[2], options, "option", - 0, &mode) != TCL_OK) { + if ((objc == 4) && Tcl_GetIndexFromObjStruct(interp, objv[2], options, + sizeof(char *), "option", 0, &mode) != TCL_OK) { return TCL_ERROR; } @@ -3947,7 +3839,7 @@ ArraySizeCmd( } } - Tcl_SetObjResult(interp, Tcl_NewIntObj(size)); + Tcl_SetObjResult(interp, Tcl_NewLongObj(size)); return TCL_OK; } @@ -4219,16 +4111,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 +4144,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 +4254,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 +4268,8 @@ TclPtrMakeUpvar( return result; } +/* Callers must Incr myNamePtr if they plan to Decr it. */ + int TclPtrObjMakeUpvar( Tcl_Interp *interp, /* Interpreter containing variables. Used for @@ -4497,60 +4391,6 @@ TclPtrObjMakeUpvar( /* *---------------------------------------------------------------------- * - * Tcl_UpVar -- - * - * This function links one variable to another, just like the "upvar" - * command. - * - * Results: - * A standard Tcl completion code. If an error occurs then an error - * message is left in the interp's result. - * - * Side effects: - * The variable in frameName whose name is given by varName becomes - * accessible under the name localNameStr, so that references to - * localNameStr are redirected to the other variable like a symbolic - * link. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_UpVar( - Tcl_Interp *interp, /* Command interpreter in which varName is to - * be looked up. */ - const char *frameName, /* Name of the frame containing the source - * variable, such as "1" or "#0". */ - const char *varName, /* Name of a variable in interp to link to. - * May be either a scalar name or an element - * in an array. */ - const char *localNameStr, /* Name of link variable. */ - int flags) /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY: - * indicates scope of localNameStr. */ -{ - int result; - CallFrame *framePtr; - Tcl_Obj *varNamePtr, *localNamePtr; - - if (TclGetFrame(interp, frameName, &framePtr) == -1) { - return TCL_ERROR; - } - - varNamePtr = Tcl_NewStringObj(varName, -1); - Tcl_IncrRefCount(varNamePtr); - localNamePtr = Tcl_NewStringObj(localNameStr, -1); - Tcl_IncrRefCount(localNamePtr); - - result = ObjMakeUpvar(interp, framePtr, varNamePtr, NULL, 0, - localNamePtr, flags, -1); - Tcl_DecrRefCount(varNamePtr); - Tcl_DecrRefCount(localNamePtr); - return result; -} - -/* - *---------------------------------------------------------------------- - * * Tcl_UpVar2 -- * * This function links one variable to another, just like the "upvar" @@ -5108,7 +4948,8 @@ ParseSearchId( * Parse the id. */ - if (Tcl_ConvertToType(interp, handleObj, &tclArraySearchType) != TCL_OK) { + if ((handleObj->typePtr != &tclArraySearchType) + && (SetArraySearchObj(interp, handleObj) != TCL_OK)) { return NULL; } @@ -5239,8 +5080,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 +5343,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 +5619,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 +5713,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 9c1176e..93e5af4 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -371,7 +371,7 @@ ConvertErrorToList( default: TclNewLiteralStringObj(objv[2], "UNKNOWN"); - TclNewIntObj(objv[3], code); + TclNewLongObj(objv[3], code); return Tcl_NewListObj(4, objv); } } @@ -545,7 +545,7 @@ ExtractHeader( &tmp); SetValue(dictObj, "comment", TclDStringToObj(&tmp)); } - SetValue(dictObj, "crc", Tcl_NewBooleanObj(headerPtr->hcrc)); + SetValue(dictObj, "crc", Tcl_NewLongObj(headerPtr->hcrc!=0)); if (headerPtr->name != Z_NULL) { if (latin1enc == NULL) { /* @@ -563,7 +563,7 @@ ExtractHeader( SetValue(dictObj, "filename", TclDStringToObj(&tmp)); } if (headerPtr->os != 255) { - SetValue(dictObj, "os", Tcl_NewIntObj(headerPtr->os)); + SetValue(dictObj, "os", Tcl_NewLongObj(headerPtr->os)); } if (headerPtr->time != 0 /* magic - no time */) { SetValue(dictObj, "time", Tcl_NewLongObj((long) headerPtr->time)); @@ -763,7 +763,7 @@ Tcl_ZlibStreamInit( */ if (interp != NULL) { - if (Tcl_Eval(interp, "::incr ::tcl::zlib::cmdcounter") != TCL_OK) { + if (Tcl_EvalEx(interp, "::incr ::tcl::zlib::cmdcounter", -1, 0) != TCL_OK) { goto error; } Tcl_DStringInit(&cmdname); @@ -2581,7 +2581,7 @@ ZlibStreamCmd( Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_ZlibStreamEof(zstream))); + Tcl_SetObjResult(interp, Tcl_NewLongObj(Tcl_ZlibStreamEof(zstream))); return TCL_OK; case zs_checksum: /* $strm checksum */ if (objc != 2) { @@ -3111,7 +3111,7 @@ ZlibTransformOutput( e = deflate(&cd->outStream, Z_NO_FLUSH); produced = cd->outAllocated - cd->outStream.avail_out; - if (e == Z_OK && cd->outStream.avail_out > 0) { + if (e == Z_OK && produced > 0) { if (Tcl_WriteRaw(cd->parent, cd->outBuffer, produced) < 0) { *errorCodePtr = Tcl_GetErrno(); return -1; @@ -3847,7 +3847,7 @@ TclZlibInit( * commands. */ - Tcl_Eval(interp, "namespace eval ::tcl::zlib {variable cmdcounter 0}"); + Tcl_EvalEx(interp, "namespace eval ::tcl::zlib {variable cmdcounter 0}", -1, 0); /* * Create the public scripted interface to this file's functionality. @@ -3865,13 +3865,13 @@ 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. */ - return Tcl_PkgProvide(interp, "zlib", TCL_ZLIB_VERSION); + return Tcl_PkgProvideEx(interp, "zlib", TCL_ZLIB_VERSION, NULL); } /* diff --git a/library/auto.tcl b/library/auto.tcl index 4bd860d..e86257e 100644 --- a/library/auto.tcl +++ b/library/auto.tcl @@ -20,8 +20,9 @@ # None. proc auto_reset {} { - if {[array exists ::auto_index]} { - foreach cmdName [array names ::auto_index] { + global auto_execs auto_index auto_path + if {[array exists auto_index]} { + foreach cmdName [array names auto_index] { set fqcn [namespace which $cmdName] if {$fqcn eq ""} { continue @@ -29,11 +30,11 @@ proc auto_reset {} { rename $fqcn {} } } - unset -nocomplain ::auto_execs ::auto_index ::tcl::auto_oldpath - if {[catch {llength $::auto_path}]} { - set ::auto_path [list [info library]] - } elseif {[info library] ni $::auto_path} { - lappend ::auto_path [info library] + unset -nocomplain auto_execs auto_index ::tcl::auto_oldpath + if {[catch {llength $auto_path}]} { + set auto_path [list [info library]] + } elseif {[info library] ni $auto_path} { + lappend auto_path [info library] } } @@ -53,7 +54,7 @@ proc auto_reset {} { proc tcl_findLibrary {basename version patch initScript enVarName varName} { upvar #0 $varName the_library - global env + global auto_path env tcl_platform set dirs {} set errors {} @@ -83,12 +84,10 @@ proc tcl_findLibrary {basename version patch initScript enVarName varName} { # 3. Relative to auto_path directories. This checks relative to the # Tcl library as well as allowing loading of libraries added to the # auto_path that is not relative to the core library or binary paths. - foreach d $::auto_path { + foreach d $auto_path { lappend dirs [file join $d $basename$version] - if { - $::tcl_platform(platform) eq "unix" - && $::tcl_platform(os) eq "Darwin" - } then { + if {$tcl_platform(platform) eq "unix" + && $tcl_platform(os) eq "Darwin"} { # 4. On MacOSX, check the Resources/Scripts subdir too lappend dirs [file join $d $basename$version Resources Scripts] } 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/library/init.tcl b/library/init.tcl index 7eeb53b..c9db41c 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -12,6 +12,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # +# This test intentionally written in pre-7.5 Tcl if {[info commands package] == ""} { error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]" } @@ -116,9 +117,10 @@ namespace eval tcl { if {(![interp issafe]) && ($tcl_platform(platform) eq "windows")} { namespace eval tcl { proc EnvTraceProc {lo n1 n2 op} { - set x $::env($n2) - set ::env($lo) $x - set ::env([string toupper $lo]) $x + global env + set x $env($n2) + set env($lo) $x + set env([string toupper $lo]) $x } proc InitWinEnv {} { global env tcl_platform @@ -159,8 +161,8 @@ if {[interp issafe]} { } else { # Set up search for Tcl Modules (TIP #189). # and setup platform specific unknown package handlers - if {$::tcl_platform(os) eq "Darwin" - && $::tcl_platform(platform) eq "unix"} { + if {$tcl_platform(os) eq "Darwin" + && $tcl_platform(platform) eq "unix"} { package unknown {::tcl::tm::UnknownHandler \ {::tcl::MacOSXPkgUnknown ::tclPkgUnknown}} } else { @@ -233,14 +235,13 @@ if {[namespace which -command tclLog] eq ""} { proc unknown args { variable ::tcl::UnknownPending - global auto_noexec auto_noload env tcl_interactive + global auto_noexec auto_noload env tcl_interactive errorInfo errorCode - - if {[info exists ::errorInfo]} { - set savedErrorInfo $::errorInfo + if {[info exists errorInfo]} { + set savedErrorInfo $errorInfo } - if {[info exists ::errorCode]} { - set savedErrorCode $::errorCode + if {[info exists errorCode]} { + set savedErrorCode $errorCode } set name [lindex $args 0] @@ -271,9 +272,9 @@ proc unknown args { unset -nocomplain ::errorCode } if {[info exists savedErrorInfo]} { - set ::errorInfo $savedErrorInfo + set errorInfo $savedErrorInfo } else { - unset -nocomplain ::errorInfo + unset -nocomplain errorInfo } set code [catch {uplevel 1 $args} msg opts] if {$code == 1} { @@ -282,8 +283,8 @@ proc unknown args { # Note the dependence on how Tcl_AddErrorInfo, etc. # construct the stack trace. # - set errorInfo [dict get $opts -errorinfo] - set errorCode [dict get $opts -errorcode] + set errInfo [dict get $opts -errorinfo] + set errCode [dict get $opts -errorcode] set cinfo $args if {[string bytelength $cinfo] > 150} { set cinfo [string range $cinfo 0 150] @@ -300,7 +301,7 @@ proc unknown args { # and trim the extra contribution from the matching case # set expect "$msg\n while executing\n\"$cinfo" - if {$errorInfo eq $expect} { + if {$errInfo eq $expect} { # # The stack has only the eval from the expanded command # Do not generate any stack trace here. @@ -315,18 +316,18 @@ proc unknown args { # set expect "\n invoked from within\n\"$cinfo" set exlen [string length $expect] - set eilen [string length $errorInfo] + set eilen [string length $errInfo] set i [expr {$eilen - $exlen - 1}] - set einfo [string range $errorInfo 0 $i] + set einfo [string range $errInfo 0 $i] # - # For now verify that $errorInfo consists of what we are about + # For now verify that $errInfo consists of what we are about # to return plus what we expected to trim off. # - if {$errorInfo ne "$einfo$expect"} { + if {$errInfo ne "$einfo$expect"} { error "Tcl bug: unexpected stack trace in \"unknown\"" {} \ - [list CORE UNKNOWN BADTRACE $einfo $expect $errorInfo] + [list CORE UNKNOWN BADTRACE $einfo $expect $errInfo] } - return -code error -errorcode $errorCode \ + return -code error -errorcode $errCode \ -errorinfo $einfo $msg } else { dict incr opts -level @@ -335,7 +336,7 @@ proc unknown args { } } - if {([info level] == 1) && ([info script] eq "") \ + if {([info level] == 1) && ([info script] eq "") && [info exists tcl_interactive] && $tcl_interactive} { if {![info exists auto_noexec]} { set new [auto_execok $name] @@ -788,7 +789,7 @@ proc tcl::CopyDirectory {action src dest} { lappend existing {*}[glob -nocomplain -directory $dest \ -type hidden * .*] foreach s $existing { - if {([file tail $s] ne ".") && ([file tail $s] ne "..")} { + if {[file tail $s] ni {. ..}} { return -code error "error $action \"$src\" to\ \"$dest\": file already exists" } @@ -796,7 +797,7 @@ proc tcl::CopyDirectory {action src dest} { } } else { if {[string first $nsrc $ndest] != -1} { - set srclen [expr {[llength [file split $nsrc]] -1}] + set srclen [expr {[llength [file split $nsrc]] - 1}] set ndest [lindex [file split $ndest] $srclen] if {$ndest eq [file tail $nsrc]} { return -code error "error $action \"$src\" to\ @@ -816,37 +817,9 @@ proc tcl::CopyDirectory {action src dest} { [glob -nocomplain -directory $src -types hidden *]] foreach s [lsort -unique $filelist] { - if {([file tail $s] ne ".") && ([file tail $s] ne "..")} { - file copy -force $s [file join $dest [file tail $s]] + if {[file tail $s] ni {. ..}} { + file copy -force -- $s [file join $dest [file tail $s]] } } return } - -# TIP 131 -if 0 { -proc tcl::rmmadwiw {} { - set magic { - 42 83 fe f6 ff f8 f1 e5 c6 f9 eb fd ff fb f1 e5 cc f5 ec f5 e3 fd fe - ff f5 fa f3 e1 c7 f9 f2 fd ff f9 fe f9 ed f4 fa f6 e6 f9 f2 e6 fd f9 - ff f9 f6 e6 fa fd ff fc fb fc f9 f1 ed - } - foreach mystic [lassign $magic tragic] { - set comic [expr (0x$mystic ^ 0x$tragic) - 255 + 0x$tragic] - append logic [format %x $comic] - set tragic $mystic - } - binary format H* $logic -} - -proc tcl::mathfunc::rmmadwiw {} { - set age [expr {9*6}] - set mind "" - while {$age} { - lappend mind [expr {$age%13}] - set age [expr {$age/13}] - } - set matter [lreverse $mind] - return [join $matter ""] -} -} diff --git a/library/msgcat/msgcat.tcl b/library/msgcat/msgcat.tcl index 5f8e1e9..77e70a5 100644 --- a/library/msgcat/msgcat.tcl +++ b/library/msgcat/msgcat.tcl @@ -13,7 +13,7 @@ package require Tcl 8.5- # When the version number changes, be sure to update the pkgIndex.tcl file, # and the installation directory in the Makefiles. -package provide msgcat 1.5.0 +package provide msgcat 1.5.1 namespace eval msgcat { namespace export mc mcload mclocale mcmax mcmset mcpreferences mcset \ @@ -287,7 +287,7 @@ proc msgcat::mcload {langdir} { } set x 0 foreach p [mcpreferences] { - if { $p eq {} } { + if {$p eq {}} { set p ROOT } set langfile [file join $langdir $p.msg] @@ -374,7 +374,7 @@ proc msgcat::mcflset {src {dest ""}} { # Results: # Returns the number of pairs processed -proc msgcat::mcmset {locale pairs } { +proc msgcat::mcmset {locale pairs} { variable Msgs set length [llength $pairs] @@ -551,10 +551,9 @@ proc msgcat::Init {} { # Examples: de-CH -> de_ch, sr-Latn-CS -> sr_cs@latin, es-419 -> es # set key {HKEY_CURRENT_USER\Control Panel\International} - if {([registry values $key "LocaleName"] ne "") + if {![catch {registry get $key LocaleName} localeName] && [regexp {^([a-z]{2,3})(?:-([a-z]{4}))?(?:-([a-z]{2}))?(?:-.+)?$}\ - [string tolower [registry get $key "LocaleName"]] match locale\ - script territory]} { + [string tolower $localeName] match locale script territory]} { if {"" ne $territory} { append locale _ $territory } @@ -562,9 +561,7 @@ proc msgcat::Init {} { if {[dict exists $modifierDict $script]} { append locale @ [dict get $modifierDict $script] } - if {![catch { - mclocale [ConvertLocale $locale] - }]} { + if {![catch {mclocale [ConvertLocale $locale]}]} { return } } diff --git a/library/msgcat/pkgIndex.tcl b/library/msgcat/pkgIndex.tcl index a5b6499..271265b 100644 --- a/library/msgcat/pkgIndex.tcl +++ b/library/msgcat/pkgIndex.tcl @@ -1,2 +1,2 @@ if {![package vsatisfies [package provide Tcl] 8.5-]} {return} -package ifneeded msgcat 1.5.0 [list source [file join $dir msgcat.tcl]] +package ifneeded msgcat 1.5.1 [list source [file join $dir msgcat.tcl]] diff --git a/library/package.tcl b/library/package.tcl index 5b99a69..a94bfaa 100644 --- a/library/package.tcl +++ b/library/package.tcl @@ -398,9 +398,7 @@ proc pkg_mkIndex {args} { foreach pkg [lsort [array names files]] { set cmd {} - foreach {name version} $pkg { - break - } + lassign $pkg name version lappend cmd ::tcl::Pkg::Create -name $name -version $version foreach spec [lsort -index 0 $files($pkg)] { foreach {file type procs} $spec { @@ -547,8 +545,7 @@ proc tclPkgUnknown {name args} { # Don't add directories we've already seen, or ones already on the # $use_path. foreach dir [lrange $auto_path $index end] { - if {![info exists tclSeenPath($dir)] - && ([lsearch -exact $use_path $dir] == -1) } { + if {![info exists tclSeenPath($dir)] && ($dir ni $use_path)} { lappend use_path $dir } } @@ -631,8 +628,7 @@ proc tcl::MacOSXPkgUnknown {original name args} { # Don't add directories we've already seen, or ones already on the # $use_path. foreach dir [lrange $auto_path $index end] { - if {![info exists tclSeenPath($dir)] - && ([lsearch -exact $use_path $dir] == -1) } { + if {![info exists tclSeenPath($dir)] && ($dir ni $use_path)} { lappend use_path $dir } } @@ -684,10 +680,7 @@ proc ::tcl::Pkg::Create {args} { } # Initialize parameters - set opts(-name) {} - set opts(-version) {} - set opts(-source) {} - set opts(-load) {} + array set opts {-name {} -version {} -source {} -load {}} # process parameters for {set i 0} {$i < $len} {incr i} { @@ -735,14 +728,9 @@ proc ::tcl::Pkg::Create {args} { # Handle -load and -source specs foreach key {load source} { foreach filespec $opts(-$key) { - foreach {filename proclist} {{} {}} { - break - } - foreach {filename proclist} $filespec { - break - } - - if {![llength $proclist]} { + lassign $filespec filename proclist + + if { [llength $proclist] == 0 } { set cmd "\[list $key \[file join \$dir [list $filename]\]\]" lappend cmdList $cmd } else { diff --git a/library/platform/pkgIndex.tcl b/library/platform/pkgIndex.tcl index 220a67b..b882e4f 100644 --- a/library/platform/pkgIndex.tcl +++ b/library/platform/pkgIndex.tcl @@ -1,3 +1,3 @@ -package ifneeded platform 1.0.10 [list source [file join $dir platform.tcl]] +package ifneeded platform 1.0.11 [list source [file join $dir platform.tcl]] package ifneeded platform::shell 1.1.4 [list source [file join $dir shell.tcl]] diff --git a/library/platform/platform.tcl b/library/platform/platform.tcl index dd2e66b..a1a728b 100644 --- a/library/platform/platform.tcl +++ b/library/platform/platform.tcl @@ -256,7 +256,7 @@ proc ::platform::LibcVersion {base _->_ vv} { if {![catch { set vdata [lindex [split [exec $libc] \n] 0] }]} { - regexp {([0-9]+(\.[0-9]+)*)} $vdata -> v + regexp {version ([0-9]+(\.[0-9]+)*), by} $vdata -> v foreach {major minor} [split $v .] break set v glibc${major}.${minor} return 1 @@ -368,7 +368,7 @@ proc ::platform::patterns {id} { # ### ### ### ######### ######### ######### ## Ready -package provide platform 1.0.10 +package provide platform 1.0.11 # ### ### ### ######### ######### ######### ## Demo application diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index 07d0a51..70df6bd 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -84,7 +84,7 @@ namespace eval tcltest { # None. # proc normalizePath {pathVar} { - upvar $pathVar path + upvar 1 $pathVar path set oldpwd [pwd] catch {cd $path} set path [pwd] @@ -247,15 +247,15 @@ namespace eval tcltest { # Kept only for compatibility Default constraintsSpecified {} AcceptList - trace variable constraintsSpecified r {set ::tcltest::constraintsSpecified \ - [array names ::tcltest::testConstraints] ;# } + trace add variable constraintsSpecified read [namespace code { + set constraintsSpecified [array names testConstraints] ;#}] # tests that use threads need to know which is the main thread Default mainThread 1 variable mainThread - if {[info commands thread::id] != {}} { + if {[info commands thread::id] ne {}} { set mainThread [thread::id] - } elseif {[info commands testthread] != {}} { + } elseif {[info commands testthread] ne {}} { set mainThread [testthread id] } @@ -263,7 +263,7 @@ namespace eval tcltest { # Tcl tests is the working directory. Whenever this value changes # change to that directory. variable workingDirectory - trace variable workingDirectory w \ + trace add variable workingDirectory write \ [namespace code {cd $workingDirectory ;#}] Default workingDirectory [pwd] AcceptAbsolutePath @@ -277,7 +277,7 @@ namespace eval tcltest { # Set the location of the execuatble Default tcltest [info nameofexecutable] - trace variable tcltest w [namespace code {testConstraint stdio \ + trace add variable tcltest write [namespace code {testConstraint stdio \ [eval [ConstraintInitializer stdio]] ;#}] # save the platform information so it can be restored later @@ -404,11 +404,11 @@ namespace eval tcltest { # already there. set outdir [normalizePath [file dirname \ [file join [pwd] $filename]]] - if {[string equal $outdir [temporaryDirectory]]} { + if {$outdir eq [temporaryDirectory]} { variable filesExisted FillFilesExisted set filename [file tail $filename] - if {[lsearch -exact $filesExisted $filename] == -1} { + if {$filename ni $filesExisted} { lappend filesExisted $filename } } @@ -448,11 +448,11 @@ namespace eval tcltest { # already there. set outdir [normalizePath [file dirname \ [file join [pwd] $filename]]] - if {[string equal $outdir [temporaryDirectory]]} { + if {$outdir eq [temporaryDirectory]} { variable filesExisted FillFilesExisted set filename [file tail $filename] - if {[lsearch -exact $filesExisted $filename] == -1} { + if {$filename ni $filesExisted} { lappend filesExisted $filename } } @@ -534,7 +534,7 @@ namespace eval tcltest { } default { # Exact match trumps ambiguity - if {[lsearch -exact $match $option] >= 0} { + if {$option in $match} { return $option } set values [join [lrange $match 0 end-1] ", "] @@ -549,7 +549,8 @@ namespace eval tcltest { variable OptionControlledVariables foreach varName [concat $OptionControlledVariables Option] { variable $varName - trace variable $varName r [namespace code {ProcessCmdLineArgs ;#}] + trace add variable $varName read [namespace code { + ProcessCmdLineArgs ;#}] } } @@ -557,11 +558,11 @@ namespace eval tcltest { variable OptionControlledVariables foreach varName [concat $OptionControlledVariables Option] { variable $varName - foreach pair [trace vinfo $varName] { - foreach {op cmd} $pair break - if {[string equal r $op] - && [string match *ProcessCmdLineArgs* $cmd]} { - trace vdelete $varName $op $cmd + foreach pair [trace info variable $varName] { + lassign $pair op cmd + if {($op eq "read") && + [string match *ProcessCmdLineArgs* $cmd]} { + trace remove variable $varName $op $cmd } } } @@ -698,7 +699,7 @@ namespace eval tcltest { Option -constraints {} { Do not skip the listed constraints listed in -constraints. } AcceptList - trace variable Option(-constraints) w \ + trace add variable Option(-constraints) write \ [namespace code {SetSelectedConstraints ;#}] # Don't run only the "-constraint" specified tests by default @@ -707,7 +708,7 @@ namespace eval tcltest { variable testConstraints if {!$Option(-limitconstraints)} {return} foreach c [array names testConstraints] { - if {[lsearch -exact $Option(-constraints) $c] == -1} { + if {$c ni $Option(-constraints)} { testConstraint $c 0 } } @@ -715,7 +716,7 @@ namespace eval tcltest { Option -limitconstraints 0 { whether to run only tests with the constraints } AcceptBoolean limitConstraints - trace variable Option(-limitconstraints) w \ + trace add variable Option(-limitconstraints) write \ [namespace code {ClearUnselectedConstraints ;#}] # A test application has to know how to load the tested commands @@ -736,7 +737,7 @@ namespace eval tcltest { } set directory [AcceptDirectory $directory] if {![file writable $directory]} { - if {[string equal [workingDirectory] $directory]} { + if {[workingDirectory] eq $directory} { # Special exception: accept the default value # even if the directory is not writable return $directory @@ -750,7 +751,7 @@ namespace eval tcltest { Option -tmpdir [workingDirectory] { Save temporary files in the specified directory. } AcceptTemporaryDirectory temporaryDirectory - trace variable Option(-tmpdir) w \ + trace add variable Option(-tmpdir) write \ [namespace code {normalizePath Option(-tmpdir) ;#}] # Tests should not rely on the current working directory. @@ -759,17 +760,17 @@ namespace eval tcltest { Option -testdir [workingDirectory] { Search tests in the specified directory. } AcceptDirectory testsDirectory - trace variable Option(-testdir) w \ + trace add variable Option(-testdir) write \ [namespace code {normalizePath Option(-testdir) ;#}] proc AcceptLoadFile { file } { - if {[string equal "" $file]} {return $file} + if {$file eq {}} {return $file} set file [file join [temporaryDirectory] $file] return [AcceptReadable $file] } proc ReadLoadScript {args} { variable Option - if {[string equal "" $Option(-loadfile)]} {return} + if {$Option(-loadfile) eq {}} {return} set tmp [open $Option(-loadfile) r] loadScript [read $tmp] close $tmp @@ -777,7 +778,7 @@ namespace eval tcltest { Option -loadfile {} { Read the script to load the tested commands from the specified file. } AcceptLoadFile loadFile - trace variable Option(-loadfile) w [namespace code ReadLoadScript] + trace add variable Option(-loadfile) write [namespace code ReadLoadScript] proc AcceptOutFile { file } { if {[string equal stderr $file]} {return $file} @@ -789,14 +790,14 @@ namespace eval tcltest { Option -outfile stdout { Send output from test runs to the specified file. } AcceptOutFile outputFile - trace variable Option(-outfile) w \ + trace add variable Option(-outfile) write \ [namespace code {outputChannel $Option(-outfile) ;#}] # errors go to stderr by default Option -errfile stderr { Send errors from test runs to the specified file. } AcceptOutFile errorFile - trace variable Option(-errfile) w \ + trace add variable Option(-errfile) write \ [namespace code {errorChannel $Option(-errfile) ;#}] proc loadIntoSlaveInterpreter {slave args} { @@ -877,7 +878,7 @@ proc tcltest::DebugPArray {level arrayvar} { variable debug if {$debug >= $level} { - catch {upvar $arrayvar $arrayvar} + catch {upvar 1 $arrayvar $arrayvar} parray $arrayvar } return @@ -961,8 +962,7 @@ proc tcltest::testConstraint {constraint {value ""}} { if {[catch {expr {$value && $value}} msg]} { return -code error $msg } - if {[limitConstraints] - && [lsearch -exact $Option(-constraints) $constraint] == -1} { + if {[limitConstraints] && ($constraint ni $Option(-constraints))} { set value 0 } set testConstraints($constraint) $value @@ -986,11 +986,7 @@ proc tcltest::interpreter { {interp ""} } { if {[llength [info level 0]] == 1} { return $tcltest } - if {[string equal {} $interp]} { - set tcltest {} - } else { - set tcltest $interp - } + set tcltest $interp } ##################################################################### @@ -1055,7 +1051,7 @@ proc tcltest::PrintError {errorMsg} { [expr {80 - $InitialMsgLen}]]] puts [errorChannel] [string range $errorMsg 0 $beginningIndex] - while {![string equal end $beginningIndex]} { + while {$beginningIndex ne "end"} { puts -nonewline [errorChannel] \ [string repeat " " $InitialMsgLen] if {($endingIndex - $beginningIndex) @@ -1108,7 +1104,7 @@ proc tcltest::PrintError {errorMsg} { proc tcltest::SafeFetch {n1 n2 op} { variable testConstraints DebugPuts 3 "entering SafeFetch $n1 $n2 $op" - if {[string equal {} $n2]} {return} + if {$n2 eq {}} {return} if {![info exists testConstraints($n2)]} { if {[catch {testConstraint $n2 [eval [ConstraintInitializer $n2]]}]} { testConstraint $n2 0 @@ -1253,9 +1249,8 @@ proc tcltest::DefineConstraintInitializers {} { # are running as root on Unix. ConstraintInitializer root {expr \ - {[string equal unix $::tcl_platform(platform)] - && ([string equal root $::tcl_platform(user)] - || [string equal "" $::tcl_platform(user)])}} + {($::tcl_platform(platform) eq "unix") && + ($::tcl_platform(user) in {root {}})}} ConstraintInitializer notRoot {expr {![testConstraint root]}} # Set nonBlockFiles constraint: 1 means this platform supports @@ -1263,7 +1258,7 @@ proc tcltest::DefineConstraintInitializers {} { ConstraintInitializer nonBlockFiles { set code [expr {[catch {set f [open defs r]}] - || [catch {fconfigure $f -blocking off}]}] + || [catch {chan configure $f -blocking off}]}] catch {close $f} set code } @@ -1289,10 +1284,10 @@ proc tcltest::DefineConstraintInitializers {} { ConstraintInitializer unixExecs { set code 1 - if {[string equal macintosh $::tcl_platform(platform)]} { + if {$::tcl_platform(platform) eq "macintosh"} { set code 0 } - if {[string equal windows $::tcl_platform(platform)]} { + if {$::tcl_platform(platform) eq "windows"} { if {[catch { set file _tcl_test_remove_me.txt makeFile {hello} $file @@ -1386,7 +1381,7 @@ proc tcltest::Usage { {option ""} } { set allOpts [concat -help [Configure]] foreach opt $allOpts { set foo [Usage $opt] - foreach [list x type($opt) usage($opt)] $foo break + lassign $foo x type($opt) usage($opt) set line($opt) " $opt $type($opt) " set length($opt) [string length $line($opt)] if {$length($opt) > $max} {set max $length($opt)} @@ -1410,7 +1405,7 @@ proc tcltest::Usage { {option ""} } { append msg $u } return $msg\n - } elseif {[string equal -help $option]} { + } elseif {$option eq "-help"} { return [list -help "" "Display this usage information."] } else { set type [lindex [info args $Verify($option)] 0] @@ -1436,7 +1431,7 @@ proc tcltest::Usage { {option ""} } { proc tcltest::ProcessFlags {flagArray} { # Process -help first - if {[lsearch -exact $flagArray {-help}] != -1} { + if {"-help" in $flagArray} { PrintUsageInfo exit 1 } @@ -1445,14 +1440,14 @@ proc tcltest::ProcessFlags {flagArray} { RemoveAutoConfigureTraces } else { set args $flagArray - while {[llength $args]>1 && [catch {configure {*}$args} msg]} { + while {[llength $args] > 1 && [catch {configure {*}$args} msg]} { # Something went wrong parsing $args for tcltest options # Check whether the problem is "unknown option" if {[regexp {^unknown option (\S+):} $msg -> option]} { # Could be this is an option the Hook knows about set moreOptions [processCmdLineArgsAddFlagsHook] - if {[lsearch -exact $moreOptions $option] == -1} { + if {$option ni $moreOptions} { # Nope. Report the error, including additional options, # but keep going if {[llength $moreOptions]} { @@ -1471,7 +1466,7 @@ proc tcltest::ProcessFlags {flagArray} { # To recover, find that unknown option and remove up to it. # then retry - while {![string equal [lindex $args 0] $option]} { + while {[lindex $args 0] ne $option} { set args [lrange $args 2 end] } set args [lrange $args 2 end] @@ -1577,7 +1572,7 @@ proc tcltest::Replace::puts {args} { } 2 { # Either -nonewline or channelId has been specified - if {[string equal -nonewline [lindex $args 0]]} { + if {[lindex $args 0] eq "-nonewline"} { append outData [lindex $args end] return # return [Puts -nonewline [lindex $args end]] @@ -1587,7 +1582,7 @@ proc tcltest::Replace::puts {args} { } } 3 { - if {[string equal -nonewline [lindex $args 0]]} { + if {[lindex $args 0] eq "-nonewline"} { # Both -nonewline and channelId are specified, unless # it's an error. -nonewline is supposed to be argv[0]. set channel [lindex $args 1] @@ -1597,12 +1592,10 @@ proc tcltest::Replace::puts {args} { } if {[info exists channel]} { - if {[string equal $channel [[namespace parent]::outputChannel]] - || [string equal $channel stdout]} { + if {$channel in [list [[namespace parent]::outputChannel] stdout]} { append outData [lindex $args end]$newline return - } elseif {[string equal $channel [[namespace parent]::errorChannel]] - || [string equal $channel stderr]} { + } elseif {$channel in [list [[namespace parent]::errorChannel] stderr]} { append errData [lindex $args end]$newline return } @@ -1771,7 +1764,7 @@ proc tcltest::SubstArguments {argList} { set argList {} } - if {$token != {}} { + if {$token ne {}} { # If we saw a word with quote before, then there is a # multi-word token starting with that word. In this case, # add the text and the current word to this token. @@ -1878,10 +1871,7 @@ proc tcltest::test {name description args} { # Pre-define everything to null except output and errorOutput. We # determine whether or not to trap output based on whether or not # these variables (output & errorOutput) are defined. - foreach item {constraints setup cleanup body result returnCodes - match} { - set $item {} - } + lassign {} constraints setup cleanup body result returnCodes match # Set the default match mode set match exact @@ -1893,8 +1883,7 @@ proc tcltest::test {name description args} { # The old test format can't have a 3rd argument (constraints or # script) that starts with '-'. - if {[string match -* [lindex $args 0]] - || ([llength $args] <= 1)} { + if {[string match -* [lindex $args 0]] || ([llength $args] <= 1)} { if {[llength $args] == 1} { set list [SubstArguments [lindex $args 0]] foreach {element value} $list { @@ -1915,7 +1904,7 @@ proc tcltest::test {name description args} { -match -output -errorOutput -constraints} foreach flag [array names testAttributes] { - if {[lsearch -exact $validFlags $flag] == -1} { + if {$flag ni $validFlags} { incr testLevel -1 set sorted [lsort $validFlags] set options [join [lrange $sorted 0 end-1] ", "] @@ -1931,7 +1920,7 @@ proc tcltest::test {name description args} { # Check the values supplied for -match variable CustomMatch - if {[lsearch [array names CustomMatch] $match] == -1} { + if {$match ni [array names CustomMatch]} { incr testLevel -1 set sorted [lsort [array names CustomMatch]] set values [join [lrange $sorted 0 end-1] ", "] @@ -1995,7 +1984,7 @@ proc tcltest::test {name description args} { } else { set testResult [uplevel 1 [list [namespace origin Eval] $command 1]] } - foreach {actualAnswer returnCode} $testResult break + lassign $testResult actualAnswer returnCode if {$returnCode == 1} { set errorInfo(body) $::errorInfo set errorCode(body) $::errorCode @@ -2031,11 +2020,11 @@ proc tcltest::test {name description args} { if {([preserveCore] > 1) && ($coreFailure)} { append coreMsg "\nMoving file to:\ [file join [temporaryDirectory] core-$name]" - catch {file rename -force \ + catch {file rename -force -- \ [file join [workingDirectory] core] \ [file join [temporaryDirectory] core-$name] } msg - if {[string length $msg] > 0} { + if {$msg ne {}} { append coreMsg "\nError:\ Problem renaming core file: $msg" } @@ -2045,7 +2034,7 @@ proc tcltest::test {name description args} { # check if the return code matched the expected return code set codeFailure 0 - if {!$setupFailure && [lsearch -exact $returnCodes $returnCode] == -1} { + if {!$setupFailure && ($returnCode ni $returnCodes)} { set codeFailure 1 } @@ -2124,7 +2113,7 @@ proc tcltest::test {name description args} { set testFd [open $testFile r] set testLine [expr {[lsearch -regexp \ [split [read $testFd] "\n"] \ - "^\[ \t\]*test [string map {. \\.} $name] "]+1}] + "^\[ \t\]*test [string map {. \\.} $name] "] + 1}] close $testFd } } @@ -2169,7 +2158,7 @@ proc tcltest::test {name description args} { puts [outputChannel] "---- Return code should have been\ one of: $returnCodes" if {[IsVerbose error]} { - if {[info exists errorInfo(body)] && ([lsearch $returnCodes 1]<0)} { + if {[info exists errorInfo(body)] && (1 ni $returnCodes)} { puts [outputChannel] "---- errorInfo: $errorInfo(body)" puts [outputChannel] "---- errorCode: $errorCode(body)" } @@ -2250,7 +2239,7 @@ proc tcltest::Skipped {name constraints} { } return 1 } - if {[string equal {} $constraints]} { + if {$constraints eq {}} { # If we're limited to the listed constraints and there aren't # any listed, then we shouldn't run the test. if {[limitConstraints]} { @@ -2401,7 +2390,7 @@ proc tcltest::cleanupTests {{calledFromAllFile 0}} { foreach file $filesMade { if {[file exists $file]} { DebugDo 1 {Warn "cleanupTests deleting $file..."} - catch {file delete -force $file} + catch {file delete -force -- $file} } } set currentFiles {} @@ -2411,7 +2400,7 @@ proc tcltest::cleanupTests {{calledFromAllFile 0}} { } set newFiles {} foreach file $currentFiles { - if {[lsearch -exact $filesExisted $file] == -1} { + if {$file ni $filesExisted} { lappend newFiles $file } } @@ -2494,8 +2483,7 @@ proc tcltest::cleanupTests {{calledFromAllFile 0}} { # then add current file to failFile list if any tests in this # file failed - if {$currentFailure \ - && ([lsearch -exact $failFiles $testFileName] == -1)} { + if {$currentFailure && ($testFileName ni $failFiles)} { lappend failFiles $testFileName } set currentFailure false @@ -2555,11 +2543,11 @@ proc tcltest::cleanupTests {{calledFromAllFile 0}} { puts [outputChannel] "produced core file! \ Moving file to: \ [file join [temporaryDirectory] core-$testFileName]" - catch {file rename -force \ + catch {file rename -force -- \ [file join [workingDirectory] core] \ [file join [temporaryDirectory] core-$testFileName] } msg - if {[string length $msg] > 0} { + if {$msg ne {}} { PrintError "Problem renaming file: $msg" } } else { @@ -2637,7 +2625,7 @@ proc tcltest::GetMatchingFiles { args } { # Add to result list all files in match list and not in skip list foreach file $matchFileList { - if {[lsearch -exact $skipFileList $file] == -1} { + if {$file ni $skipFileList} { lappend matchingFiles $file } } @@ -2684,7 +2672,7 @@ proc tcltest::GetMatchingDirectories {rootdir} { foreach pattern [matchDirectories] { foreach path [glob -directory $rootdir -types d -nocomplain -- \ $pattern] { - if {[lsearch -exact $skipDirs $path] == -1} { + if {$path ni $skipDirs} { set matchDirs [concat $matchDirs [GetMatchingDirectories $path]] if {[file exists [file join $path all.tcl]]} { lappend matchDirs $path @@ -2737,7 +2725,7 @@ proc tcltest::runAllTests { {shell ""} } { # [file system] first available in Tcl 8.4 if {![catch {file system [testsDirectory]} result] - && ![string equal native [lindex $result 0]]} { + && ([lindex $result 0] ne "native")} { # If we aren't running in the native filesystem, then we must # run the tests in a single process (via 'source'), because # trying to run then via a pipe will fail since the files don't @@ -2784,10 +2772,10 @@ proc tcltest::runAllTests { {shell ""} } { # needs to read and process output of children. set childargv [list] foreach opt [Configure] { - if {[string equal $opt -outfile]} {continue} + if {$opt eq "-outfile"} {continue} set value [Configure $opt] # Don't bother passing default configuration options - if {[string equal $value $DefaultValue($opt)]} { + if {$value eq $DefaultValue($opt)} { continue } lappend childargv $opt $value @@ -2880,11 +2868,6 @@ proc tcltest::runAllTests { {shell ""} } { # none. proc tcltest::loadTestedCommands {} { - variable l - if {[string equal {} [loadScript]]} { - return - } - return [uplevel 1 [loadScript]] } @@ -2927,16 +2910,15 @@ proc tcltest::saveState {} { proc tcltest::restoreState {} { variable saveState foreach p [uplevel 1 {::info procs}] { - if {([lsearch [lindex $saveState 0] $p] < 0) - && ![string equal [namespace current]::$p \ - [uplevel 1 [list ::namespace origin $p]]]} { + if {($p ni [lindex $saveState 0]) && ("[namespace current]::$p" ne + [uplevel 1 [list ::namespace origin $p]])} { DebugPuts 2 "[lindex [info level 0] 0]: Removing proc $p" uplevel 1 [list ::catch [list ::rename $p {}]] } } foreach p [uplevel 1 {::info vars}] { - if {[lsearch [lindex $saveState 1] $p] < 0} { + if {$p ni [lindex $saveState 1]} { DebugPuts 2 "[lindex [info level 0] 0]:\ Removing variable $p" uplevel 1 [list ::catch [list ::unset $p]] @@ -2997,15 +2979,15 @@ proc tcltest::makeFile {contents name {directory ""}} { putting ``$contents'' into $fullName" set fd [open $fullName w] - fconfigure $fd -translation lf - if {[string equal [string index $contents end] \n]} { + chan configure $fd -translation lf + if {[string index $contents end] eq "\n"} { puts -nonewline $fd $contents } else { puts $fd $contents } close $fd - if {[lsearch -exact $filesMade $fullName] == -1} { + if {$fullName ni $filesMade} { lappend filesMade $fullName } return $fullName @@ -3045,7 +3027,7 @@ proc tcltest::removeFile {name {directory ""}} { Warn "removeFile removing \"$fullName\":\n not a file" } } - return [file delete $fullName] + return [file delete -- $fullName] } # tcltest::makeDirectory -- @@ -3075,7 +3057,7 @@ proc tcltest::makeDirectory {name {directory ""}} { set fullName [file join $directory $name] DebugPuts 3 "[lindex [info level 0] 0]: creating $fullName" file mkdir $fullName - if {[lsearch -exact $filesMade $fullName] == -1} { + if {$fullName ni $filesMade} { lappend filesMade $fullName } return $fullName @@ -3116,7 +3098,7 @@ proc tcltest::removeDirectory {name {directory ""}} { Warn "removeDirectory removing \"$fullName\":\n not a directory" } } - return [file delete -force $fullName] + return [file delete -force -- $fullName] } # tcltest::viewFile -- @@ -3213,7 +3195,7 @@ proc tcltest::LeakFiles {old} { } set leak {} foreach p $new { - if {[lsearch $old $p] < 0} { + if {$p ni $old} { lappend leak $p } } @@ -3284,7 +3266,7 @@ proc tcltest::RestoreLocale {} { # proc tcltest::threadReap {} { - if {[info commands testthread] != {}} { + if {[info commands testthread] ne {}} { # testthread built into tcltest @@ -3304,7 +3286,7 @@ proc tcltest::threadReap {} { } testthread errorproc ThreadError return [llength [testthread names]] - } elseif {[info commands thread::id] != {}} { + } elseif {[info commands thread::id] ne {}} { # Thread extension @@ -3336,15 +3318,15 @@ namespace eval tcltest { # Set up the constraints in the testConstraints array to be lazily # initialized by a registered initializer, or by "false" if no # initializer is registered. - trace variable testConstraints r [namespace code SafeFetch] + trace add variable testConstraints read [namespace code SafeFetch] # Only initialize constraints at package load time if an # [initConstraintsHook] has been pre-defined. This is only # for compatibility support. The modern way to add a custom # test constraint is to just call the [testConstraint] command # straight away, without all this "hook" nonsense. - if {[string equal [namespace current] \ - [namespace qualifiers [namespace which initConstraintsHook]]]} { + if {[namespace current] eq + [namespace qualifiers [namespace which initConstraintsHook]]} { InitConstraints } else { proc initConstraintsHook {} {} @@ -3381,15 +3363,15 @@ namespace eval tcltest { proc LoadTimeCmdLineArgParsingRequired {} { set required false - if {[info exists ::argv] && [lsearch -exact $::argv -help] != -1} { + if {[info exists ::argv] && ("-help" in $::argv)} { # The command line asks for -help, so give it (and exit) # right now. ([configure] does not process -help) set required true } foreach hook { PrintUsageInfoHook processCmdLineArgsHook processCmdLineArgsAddFlagsHook } { - if {[string equal [namespace current] [namespace qualifiers \ - [namespace which $hook]]]} { + if {[namespace current] eq + [namespace qualifiers [namespace which $hook]]} { set required true } else { proc $hook args {} diff --git a/library/tm.tcl b/library/tm.tcl index 4288658..74d93a5 100644 --- a/library/tm.tcl +++ b/library/tm.tcl @@ -54,7 +54,7 @@ namespace eval ::tcl::tm { # Export the public API namespace export path - namespace ensemble create -command path -subcommand {add remove list} + namespace ensemble create -command path -subcommands {add remove list} } # ::tcl::tm::path implementations -- @@ -260,10 +260,8 @@ proc ::tcl::tm::UnknownHandler {original name args} { # Otherwise we still have to fallback to the regular # package search to complete the processing. - if { - ($pkgname eq $name) && - [package vsatisfies $pkgversion {*}$args] - } then { + if {($pkgname eq $name) + && [package vsatisfies $pkgversion {*}$args]} { set satisfied 1 # We do not abort the loop, and keep adding provide @@ -342,7 +340,6 @@ proc ::tcl::tm::Defaults {} { } } } - } return } @@ -360,7 +357,7 @@ proc ::tcl::tm::Defaults {} { # Calls 'path add' to paths to the list of module search paths. proc ::tcl::tm::roots {paths} { - foreach {major minor} [split [info tclversion] .] break + regexp {^(\d+)\.(\d+)} [package present Tcl] - major minor foreach pa $paths { set p [file join $pa tcl$major] for {set n $minor} {$n >= 0} {incr n -1} { diff --git a/library/word.tcl b/library/word.tcl index 16a4638..b8f34a5 100644 --- a/library/word.tcl +++ b/library/word.tcl @@ -67,7 +67,7 @@ namespace eval ::tcl { proc tcl_wordBreakAfter {str start} { variable ::tcl::WordBreakRE set result {-1 -1} - regexp -indices -start $start $WordBreakRE(after) $str result + regexp -indices -start $start -- $WordBreakRE(after) $str result return [lindex $result 1] } @@ -85,7 +85,7 @@ proc tcl_wordBreakAfter {str start} { proc tcl_wordBreakBefore {str start} { variable ::tcl::WordBreakRE set result {-1 -1} - regexp -indices $WordBreakRE(before) [string range $str 0 $start] result + regexp -indices -- $WordBreakRE(before) [string range $str 0 $start] result return [lindex $result 1] } @@ -104,7 +104,7 @@ proc tcl_wordBreakBefore {str start} { proc tcl_endOfWord {str start} { variable ::tcl::WordBreakRE set result {-1 -1} - regexp -indices -start $start $WordBreakRE(end) $str result + regexp -indices -start $start -- $WordBreakRE(end) $str result return [lindex $result 1] } @@ -122,7 +122,7 @@ proc tcl_endOfWord {str start} { proc tcl_startOfNextWord {str start} { variable ::tcl::WordBreakRE set result {-1 -1} - regexp -indices -start $start $WordBreakRE(next) $str result + regexp -indices -start $start -- $WordBreakRE(next) $str result return [lindex $result 1] } @@ -138,7 +138,7 @@ proc tcl_startOfNextWord {str start} { proc tcl_startOfPreviousWord {str start} { variable ::tcl::WordBreakRE set word {-1 -1} - regexp -indices $WordBreakRE(previous) [string range $str 0 $start-1] \ + regexp -indices -- $WordBreakRE(previous) [string range $str 0 $start-1] \ result word return [lindex $word 0] } diff --git a/macosx/tclMacOSXFCmd.c b/macosx/tclMacOSXFCmd.c index f266443..d16f33f 100644 --- a/macosx/tclMacOSXFCmd.c +++ b/macosx/tclMacOSXFCmd.c @@ -192,7 +192,7 @@ TclMacOSXGetFileAttribute( OSSwapBigToHostInt32(finder->type)); break; case MACOSX_HIDDEN_ATTRIBUTE: - *attributePtrPtr = Tcl_NewBooleanObj( + *attributePtrPtr = Tcl_NewLongObj( (finder->fdFlags & kFinfoIsInvisible) != 0); break; case MACOSX_RSRCLENGTH_ATTRIBUTE: @@ -578,7 +578,7 @@ GetOSTypeFromObj( int result = TCL_OK; if (objPtr->typePtr != &tclOSTypeType) { - result = tclOSTypeType.setFromAnyProc(interp, objPtr); + result = SetOSTypeFromAny(interp, objPtr); } *osTypePtr = (OSType) objPtr->internalRep.longValue; return result; @@ -608,7 +608,7 @@ NewOSTypeObj( Tcl_Obj *objPtr; TclNewObj(objPtr); - Tcl_InvalidateStringRep(objPtr); + TclInvalidateStringRep(objPtr); objPtr->internalRep.longValue = (long) osType; objPtr->typePtr = &tclOSTypeType; return objPtr; 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/assocd.test b/tests/assocd.test index d1489b3..edf55c4 100644 --- a/tests/assocd.test +++ b/tests/assocd.test @@ -11,10 +11,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import -force ::tcltest::* -} +package require tcltest 2 +namespace import ::tcltest::* ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] @@ -36,15 +34,21 @@ test assocd-1.4 {testing setting assoc data} testsetassocdata { testsetassocdata abc "abc d e f" } "" -test assocd-2.1 {testing getting assoc data} testgetassocdata { - testgetassocdata a -} 2 -test assocd-2.2 {testing getting assoc data} testgetassocdata { - testgetassocdata 123 -} 456 -test assocd-2.3 {testing getting assoc data} testgetassocdata { +test assocd-2.1 {testing getting assoc data} -setup { + testsetassocdata a 2 +} -constraints {testgetassocdata} -body { + testgetassocdata a +} -result 2 +test assocd-2.2 {testing getting assoc data} -setup { + testsetassocdata 123 456 +} -constraints {testgetassocdata} -body { + testgetassocdata 123 +} -result 456 +test assocd-2.3 {testing getting assoc data} -setup { + testsetassocdata abc "abc d e f" +} -constraints {testgetassocdata} -body { testgetassocdata abc -} {abc d e f} +} -result "abc d e f" test assocd-2.4 {testing getting assoc data} testgetassocdata { testgetassocdata xxx } "" @@ -60,5 +64,5 @@ test assocd-3.3 {testing deleting assoc data} testdelassocdata { } {0 {}} # cleanup -::tcltest::cleanupTests +cleanupTests return diff --git a/tests/basic.test b/tests/basic.test index 7435571..1a0037c 100644 --- a/tests/basic.test +++ b/tests/basic.test @@ -16,7 +16,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. package require tcltest 2 -namespace import -force ::tcltest::* +namespace import ::tcltest::* ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] @@ -31,7 +31,7 @@ catch {interp delete test_interp} catch {rename p ""} catch {rename q ""} catch {rename cmd ""} -catch {unset x} +unset -nocomplain x test basic-1.1 {Tcl_CreateInterp, creates interp's global namespace} { catch {interp delete test_interp} @@ -267,14 +267,24 @@ test basic-18.4 {TclRenameCommand, bad new name} { } rename test_ns_basic::p :::george::martha } {} -test basic-18.5 {TclRenameCommand, new name must not already exist} { +test basic-18.5 {TclRenameCommand, new name must not already exist} -setup { + if {![llength [info commands :::george::martha]]} { + catch {namespace delete {*}[namespace children :: test_ns_*]} + namespace eval test_ns_basic { + proc p {} { + return "p in [namespace current]" + } + } + rename test_ns_basic::p :::george::martha + } +} -body { namespace eval test_ns_basic { proc q {} { return 42 } } list [catch {rename test_ns_basic::q :::george::martha} msg] $msg -} {1 {can't rename to ":::george::martha": command already exists}} +} -result {1 {can't rename to ":::george::martha": command already exists}} test basic-18.6 {TclRenameCommand, check for command shadowing by newly renamed cmd} { catch {namespace delete {*}[namespace children :: test_ns_*]} catch {rename p ""} @@ -302,7 +312,7 @@ test basic-20.1 {Tcl_GetCommandInfo, names for commands created inside namespace catch {namespace delete {*}[namespace children :: test_ns_*]} catch {rename p ""} catch {rename q ""} - catch {unset x} + unset -nocomplain x set x [namespace eval test_ns_basic::test_ns_basic2 { # the following creates a cmd in the global namespace testcmdtoken create p @@ -355,7 +365,7 @@ test basic-23.1 {Tcl_DeleteCommand} {emptyTest} { test basic-24.1 {Tcl_DeleteCommandFromToken, invalidate all compiled code if cmd has compile proc} { catch {interp delete test_interp} - catch {unset x} + unset -nocomplain x interp create test_interp interp eval test_interp { proc useSet {} { @@ -427,7 +437,7 @@ test basic-26.1 {Tcl_EvalObj: preserve object while evaling it} -setup { # string would have been freed, leaving garbage bytes for the error # message. set f [open $fName w] - fileevent $f writable "fileevent $f writable {}; error foo" + chan event $f writable "chan event $f writable {}; error foo" set x {} vwait x close $f @@ -547,8 +557,8 @@ test basic-46.1 {Tcl_AllowExceptions: exception return not allowed} {stdio} { catch {close $f} set res [catch { set f [open |[list [interpreter]] w+] - fconfigure $f -buffering line - puts $f {fconfigure stdout -buffering line} + chan configure $f -buffering line + puts $f {chan configure stdout -buffering line} puts $f continue puts $f {puts $::errorInfo} puts $f {puts DONE} @@ -972,6 +982,6 @@ catch {rename p ""} catch {rename q ""} catch {rename cmd ""} catch {rename value:at: ""} -catch {unset x} -::tcltest::cleanupTests +unset -nocomplain x +cleanupTests return diff --git a/tests/binary.test b/tests/binary.test index ccd0f29..4393245 100644 --- a/tests/binary.test +++ b/tests/binary.test @@ -1582,38 +1582,46 @@ test binary-40.4 {ScanNumber: NaN} -body { list [binary scan \xff\xff\xff\xff\xff\xff\xff\xff d arg1] $arg1 } -match glob -result {1 -NaN*} -test binary-41.1 {ScanNumber: word alignment} { - unset -nocomplain arg1; unset arg2 +test binary-41.1 {ScanNumber: word alignment} -setup { + unset -nocomplain arg1 arg2 +} -body { list [binary scan \x01\x01\x00 c1s1 arg1 arg2] $arg1 $arg2 -} {2 1 1} -test binary-41.2 {ScanNumber: word alignment} { - unset -nocomplain arg1; unset arg2 +} -result {2 1 1} +test binary-41.2 {ScanNumber: word alignment} -setup { + unset -nocomplain arg1 arg2 +} -body { list [binary scan \x01\x00\x01 c1S1 arg1 arg2] $arg1 $arg2 -} {2 1 1} -test binary-41.3 {ScanNumber: word alignment} { - unset -nocomplain arg1; unset arg2 +} -result {2 1 1} +test binary-41.3 {ScanNumber: word alignment} -setup { + unset -nocomplain arg1 arg2 +} -body { list [binary scan \x01\x01\x00\x00\x00 c1i1 arg1 arg2] $arg1 $arg2 -} {2 1 1} -test binary-41.4 {ScanNumber: word alignment} { - unset -nocomplain arg1; unset arg2 +} -result {2 1 1} +test binary-41.4 {ScanNumber: word alignment} -setup { + unset -nocomplain arg1 arg2 +} -body { list [binary scan \x01\x00\x00\x00\x01 c1I1 arg1 arg2] $arg1 $arg2 -} {2 1 1} -test binary-41.5 {ScanNumber: word alignment} bigEndian { - unset -nocomplain arg1; unset arg2 +} -result {2 1 1} +test binary-41.5 {ScanNumber: word alignment} -setup { + unset -nocomplain arg1 arg2 +} -constraints bigEndian -body { list [binary scan \x01\x3f\xcc\xcc\xcd c1f1 arg1 arg2] $arg1 $arg2 -} {2 1 1.600000023841858} -test binary-41.6 {ScanNumber: word alignment} littleEndian { - unset -nocomplain arg1; unset arg2 +} -result {2 1 1.600000023841858} +test binary-41.6 {ScanNumber: word alignment} -setup { + unset -nocomplain arg1 arg2 +} -constraints littleEndian -body { list [binary scan \x01\xcd\xcc\xcc\x3f c1f1 arg1 arg2] $arg1 $arg2 -} {2 1 1.600000023841858} -test binary-41.7 {ScanNumber: word alignment} bigEndian { - unset -nocomplain arg1; unset arg2 +} -result {2 1 1.600000023841858} +test binary-41.7 {ScanNumber: word alignment} -setup { + unset -nocomplain arg1 arg2 +} -constraints bigEndian -body { list [binary scan \x01\x3f\xf9\x99\x99\x99\x99\x99\x9a c1d1 arg1 arg2] $arg1 $arg2 -} {2 1 1.6} -test binary-41.8 {ScanNumber: word alignment} littleEndian { - unset -nocomplain arg1; unset arg2 +} -result {2 1 1.6} +test binary-41.8 {ScanNumber: word alignment} -setup { + unset -nocomplain arg1 arg2 +} -constraints littleEndian -body { list [binary scan \x01\x9a\x99\x99\x99\x99\x99\xf9\x3f c1d1 arg1 arg2] $arg1 $arg2 -} {2 1 1.6} +} -result {2 1 1.6} test binary-42.1 {Tcl_BinaryObjCmd: bad arguments} -constraints {} -body { binary ? diff --git a/tests/chanio.test b/tests/chanio.test index 665df50..999d0bb 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -2214,13 +2214,17 @@ test chan-io-28.7 {Tcl_CloseEx (half-close) socket} -setup { puts $sok DONE exit 0 } echo.tcl] -} -body { + variable done + unset -nocomplain done + set done "" + set timer "" set ff [openpipe r $echo] gets $ff port +} -body { set s [socket 127.0.0.1 $port] puts $s Hey close $s w - set timer [after 1000 [namespace code {set ::done Failed}]] + set timer [after 1000 [namespace code {set done Failed}]] set acc {} fileevent $s readable [namespace code { if {[gets $s line]<0} { @@ -2230,11 +2234,11 @@ test chan-io-28.7 {Tcl_CloseEx (half-close) socket} -setup { } }] vwait [namespace which -variable done] - after cancel $timer - close $s r - close $ff list $done $acc } -cleanup { + catch {close $s} + close $ff + after cancel $timer removeFile echo.tcl } -result {Succeeded {Hey DONE}} diff --git a/tests/cmdInfo.test b/tests/cmdInfo.test index 69d7171..0a587e8 100644 --- a/tests/cmdInfo.test +++ b/tests/cmdInfo.test @@ -13,10 +13,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 - namespace import -force ::tcltest::* -} +package require tcltest 2 +namespace import ::tcltest::* ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] @@ -101,7 +99,7 @@ test cmdinfo-6.1 {Names for commands created when outside namespaces} \ # cleanup catch {namespace delete cmdInfoNs1::cmdInfoNs2 cmdInfoNs1} catch {rename x1 ""} -::tcltest::cleanupTests +cleanupTests return # Local Variables: diff --git a/tests/coroutine.test b/tests/coroutine.test index 8272717..1d9040b 100644 --- a/tests/coroutine.test +++ b/tests/coroutine.test @@ -439,7 +439,7 @@ test coroutine-4.5 {bug #2724403} -constraints {memory} \ } -result 0 test coroutine-4.6 {compile context, bug #3282869} -setup { - unset ::x + unset -nocomplain ::x proc f x { coroutine D eval {yield X$x;yield Y} } diff --git a/tests/dcall.test b/tests/dcall.test index 3df0ac8..41dd777 100644 --- a/tests/dcall.test +++ b/tests/dcall.test @@ -11,10 +11,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import -force ::tcltest::* -} +package require tcltest 2 +namespace import ::tcltest::* ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] @@ -41,5 +39,5 @@ test dcall-1.6 {deletion callbacks} testdcall { } {} # cleanup -::tcltest::cleanupTests +cleanupTests return 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/expr-old.test b/tests/expr-old.test index ed0f11f..7d6e6f8 100644 --- a/tests/expr-old.test +++ b/tests/expr-old.test @@ -13,10 +13,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2.1 - namespace import -force ::tcltest::* -} +package require tcltest 2.1 +namespace import ::tcltest::* ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] @@ -139,7 +137,7 @@ test expr-old-1.50 {integer operators} {expr +36} 36 test expr-old-1.51 {integer operators} {expr +--++36} 36 test expr-old-1.52 {integer operators} {expr +36%+5} 1 test expr-old-1.53 {integer operators} { - catch {unset x} + unset -nocomplain x set x yes list [expr {1 && $x}] [expr {$x && 1}] \ [expr {0 || $x}] [expr {$x || 0}] @@ -447,7 +445,7 @@ test expr-old-23.3 {double quotes} { test expr-old-23.4 {double quotes} {expr {"11\}\}22"}} 11}}22 test expr-old-23.5 {double quotes} {expr {"\*bc"}} {*bc} test expr-old-23.6 {double quotes} { - catch {unset bogus__} + unset -nocomplain bogus__ list [catch {expr {"$bogus__"}} msg] $msg } {1 {can't read "bogus__": no such variable}} test expr-old-23.7 {double quotes} { @@ -496,7 +494,7 @@ test expr-old-26.2 {error conditions} -body { test expr-old-26.3 {error conditions} -body { expr 2+4*( } -returnCodes error -match glob -result * -catch {unset _non_existent_} +unset -nocomplain _non_existent_ test expr-old-26.4 {error conditions} { list [catch {expr 2+$_non_existent_} msg] $msg } {1 {can't read "_non_existent_": no such variable}} @@ -575,7 +573,7 @@ test expr-old-27.4 {cancelled evaluation} { expr {1?2:[set a 2]} set a } 1 -catch {unset x} +unset -nocomplain x test expr-old-27.5 {cancelled evaluation} { list [catch {expr {[info exists x] && $x}} msg] $msg } {0 0} 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..d7fb46c 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: Tcl_ListObjReplace refcount management} testobj { + testobj bug3598580 +} 123 + # cleanup ::tcltest::cleanupTests return diff --git a/tests/lmap.test b/tests/lmap.test index 7baa77b..08035d9 100644 --- a/tests/lmap.test +++ b/tests/lmap.test @@ -18,7 +18,7 @@ if {"::tcltest" ni [namespace children]} { namespace import -force ::tcltest::* } -unset -nocomplain a i x +unset -nocomplain a b i x # ----- Non-compiled operation ----------------------------------------------- @@ -404,14 +404,21 @@ test lmap-7.6 {lmap: related to "foreach" [Bug 1671087]} -setup { rename demo {} } -result {2 4} # Huge lists must not overflow the bytecode interpreter (development bug) -test lmap-7.7 {huge list non-compiled} { +test lmap-7.7 {huge list non-compiled} -setup { + unset -nocomplain a b x +} -body { set x [lmap a [lrepeat 1000000 x] { set b y$a }] list $b [llength $x] [string length $x] -} {yx 1000000 2999999} -test lmap-7.8 {huge list compiled} { - set x [apply {{times} { lmap a [lrepeat $times x] { set b y$a }}} 1000000] +} -result {yx 1000000 2999999} +test lmap-7.8 {huge list compiled} -setup { + unset -nocomplain a b x +} -body { + set x [apply {{times} { + global b + lmap a [lrepeat $times x] { set b Y$a } + }} 1000000] list $b [llength $x] [string length $x] -} {yx 1000000 2999999} +} -result {Yx 1000000 2999999} test lmap-7.9 {error then dereference loop var (dev bug)} { catch { lmap a 0 b {1 2 3} { error x } } set a diff --git a/tests/main.test b/tests/main.test index 7fd9d73..c22d83b 100644 --- a/tests/main.test +++ b/tests/main.test @@ -129,7 +129,7 @@ namespace eval ::tcl::test::main { set script [makeFile {} script] file delete $script set f [open $script w] - fconfigure $f -encoding utf-8 + chan configure $f -encoding utf-8 puts $f {puts [list $argv0 $argv $tcl_interactive]} puts -nonewline $f {puts [string equal \u20ac } puts $f "\u20ac]" @@ -150,7 +150,7 @@ namespace eval ::tcl::test::main { set script [makeFile {} script] file delete $script set f [open $script w] - fconfigure $f -encoding utf-8 + chan configure $f -encoding utf-8 puts $f {puts [list $argv0 $argv $tcl_interactive]} puts -nonewline $f {puts [string equal \u20ac } puts $f "\u20ac]" @@ -171,7 +171,7 @@ namespace eval ::tcl::test::main { set script [makeFile {} script] file delete $script set f [open $script w] - fconfigure $f -encoding utf-8 + chan configure $f -encoding utf-8 puts $f {puts [list $argv0 $argv $tcl_interactive]} puts -nonewline $f {puts [string equal \u20ac } puts $f "\u20ac]" @@ -592,7 +592,7 @@ namespace eval ::tcl::test::main { catch {set f [open "|[list [interpreter]]" w+]} } -body { type $f { - fconfigure stdin -blocking 0 + chan configure stdin -blocking 0 puts SUCCESS } list [catch {gets $f} line] $line @@ -606,19 +606,19 @@ namespace eval ::tcl::test::main { exec } -setup { catch {set f [open "|[list [interpreter]]" w+]} - catch {fconfigure $f -blocking 0} + catch {chan configure $f -blocking 0} } -body { - type $f "fconfigure stdin -eofchar \\032 + type $f "chan configure stdin -eofchar \\032 if 1 \{\n\032" variable wait - fileevent $f readable \ + chan event $f readable \ [list set [namespace which -variable wait] "child exit"] set id [after 2000 [list set [namespace which -variable wait] timeout]] vwait [namespace which -variable wait] after cancel $id set wait } -cleanup { - if {[string equal timeout $wait] && [testConstraint unix]} { + if {$wait eq "timeout" && [testConstraint unix]} { exec kill [pid $f] } close $f @@ -631,17 +631,17 @@ namespace eval ::tcl::test::main { } -setup { set cmd {makeFile "if 1 \{" script} catch {set f [open "|[list [interpreter]] < [list [eval $cmd]]" r]} - catch {fconfigure $f -blocking 0} + catch {chan configure $f -blocking 0} } -body { variable wait - fileevent $f readable \ + chan event $f readable \ [list set [namespace which -variable wait] "child exit"] set id [after 2000 [list set [namespace which -variable wait] timeout]] vwait [namespace which -variable wait] after cancel $id set wait } -cleanup { - if {[string equal timeout $wait] && [testConstraint unix]} { + if {$wait eq "timeout" && [testConstraint unix]} { exec kill [pid $f] } close $f @@ -748,7 +748,7 @@ namespace eval ::tcl::test::main { exec Tcltest } -setup { catch {set f [open "|[list [interpreter]]" w+]} - catch {fconfigure $f -blocking 0} + catch {chan configure $f -blocking 0} } -body { type $f "testsetmainloop after 2000 testexitmainloop @@ -983,7 +983,7 @@ namespace eval ::tcl::test::main { } -body { exec [interpreter] << { testsetmainloop - fconfigure stdin -blocking 0 + chan configure stdin -blocking 0 testexitmainloop } >& result set f [open result] diff --git a/tests/msgcat.test b/tests/msgcat.test index 9fb565b..a0b88dd 100644 --- a/tests/msgcat.test +++ b/tests/msgcat.test @@ -12,13 +12,13 @@ # Note that after running these tests, entries will be left behind in the # message catalogs for locales foo, foo_BAR, and foo_BAR_baz. -package require Tcl 8.2- +package require Tcl 8.5- if {[catch {package require tcltest 2}]} { puts stderr "Skipping tests in [info script]. tcltest 2 required." return } -if {[catch {package require msgcat 1.5.0}]} { - puts stderr "Skipping tests in [info script]. No msgcat 1.5.0 found to test." +if {[catch {package require msgcat 1.5}]} { + puts stderr "Skipping tests in [info script]. No msgcat 1.5 found to test." return } @@ -56,7 +56,7 @@ namespace eval ::msgcat::test { set result [string tolower \ [msgcat::ConvertLocale $::tcl::mac::locale]] } else { - if {([info sharedlibextension] == ".dll") + if {([info sharedlibextension] eq ".dll") && ![catch {package require registry}]} { # Windows and Cygwin have other ways to determine the # locale when the environment variables are missing @@ -72,7 +72,7 @@ namespace eval ::msgcat::test { variable var foreach var $envVars { catch {variable $var $::env($var)} - catch {unset ::env($var)} + unset -nocomplain ::env($var) } foreach var $setVars { set ::env($var) $var @@ -84,13 +84,13 @@ namespace eval ::msgcat::test { } -cleanup { interp delete [namespace current]::i foreach var $envVars { - catch {unset ::env($var)} + unset -nocomplain ::env($var) catch {set ::env($var) [set [namespace current]::$var]} } } -body {i eval msgcat::mclocale} -result $result incr count } - catch {unset result} + unset -nocomplain result # Could add tests of initialization from Windows registry here. # Use a fake registry package. @@ -324,7 +324,7 @@ namespace eval ::msgcat::test { incr count } } - catch {unset result} + unset -nocomplain result # Tests msgcat-4.*: [mcunknown] diff --git a/tests/namespace.test b/tests/namespace.test index 1d46bf0..f6688f1 100644 --- a/tests/namespace.test +++ b/tests/namespace.test @@ -1111,6 +1111,14 @@ test namespace-26.7 {NamespaceExportCmd, -clear resets export list} { } list [lsort [info commands test_ns_2::*]] [test_ns_2::cmd4 hello] } [list [lsort {::test_ns_2::cmd4 ::test_ns_2::cmd1 ::test_ns_2::cmd3}] {cmd4: hello}] +test namespace-26.8 {NamespaceExportCmd, -clear resets export list} { + catch {namespace delete foo} + namespace eval foo { + namespace export x + namespace export -clear + } + list [namespace eval foo namespace export] [namespace delete foo] +} {{} {}} test namespace-27.1 {NamespaceForgetCmd, no args} { catch {namespace delete {*}[namespace children :: test_ns_*]} 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..49fe150 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::* @@ -2204,6 +2204,25 @@ test oo-19.2 {OO: varname method: Bug 2883857} -setup { } -cleanup { SpecialClass destroy } -result ::oo_test::x(y) +test oo-19.3 {OO: varname method and variable decl: Bug 3603695} -setup { + oo::class create testClass { + variable foo + export varname + constructor {} { + variable foo x + } + method bar {obj} { + my varname foo + $obj varname foo + } + } +} -body { + testClass create A + testClass create B + lsearch [list [A varname foo] [B varname foo]] [B bar A] +} -cleanup { + testClass destroy +} -result 0 test oo-20.1 {OO: variable method} -body { oo::class create testClass { 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..b9cfe80 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 @@ -438,7 +439,7 @@ test parse-8.12 {Tcl_EvalObjv procedure, TCL_EVAL_INVOKE} { test parse-9.1 {Tcl_LogCommandInfo, line numbers} testevalex { - catch {unset x} + unset -nocomplain x list [catch {testevalex {for {} 1 {} { @@ -479,7 +480,7 @@ test parse-10.3 {Tcl_EvalTokens, nested commands} testevalex { testevalex {concat [expr 2 + 6]} } {8} test parse-10.4 {Tcl_EvalTokens, nested commands} testevalex { - catch {unset a} + unset -nocomplain a list [catch {testevalex {concat xxx[expr $a]}} msg] $msg } {1 {can't read "a": no such variable}} test parse-10.5 {Tcl_EvalTokens, simple variables} testevalex { @@ -487,21 +488,21 @@ test parse-10.5 {Tcl_EvalTokens, simple variables} testevalex { testevalex {concat $a} } {hello} test parse-10.6 {Tcl_EvalTokens, array variables} testevalex { - catch {unset a} + unset -nocomplain a set a(12) 46 testevalex {concat $a(12)} } {46} test parse-10.7 {Tcl_EvalTokens, array variables} testevalex { - catch {unset a} + unset -nocomplain a set a(12) 46 testevalex {concat $a(1[expr 3 - 1])} } {46} test parse-10.8 {Tcl_EvalTokens, array variables} testevalex { - catch {unset a} + unset -nocomplain a list [catch {testevalex {concat $x($a)}} msg] $msg } {1 {can't read "a": no such variable}} test parse-10.9 {Tcl_EvalTokens, array variables} testevalex { - catch {unset a} + unset -nocomplain a list [catch {testevalex {concat xyz$a(1)}} msg] $msg } {1 {can't read "a(1)": no such variable}} test parse-10.10 {Tcl_EvalTokens, object values} testevalex { @@ -541,11 +542,11 @@ test parse-11.2 {Tcl_EvalEx, error while parsing} testevalex { list [catch {testevalex {concat "abc}} msg] $msg } {1 {missing "}} test parse-11.3 {Tcl_EvalEx, error while collecting words} testevalex { - catch {unset a} + unset -nocomplain a list [catch {testevalex {concat xyz $a}} msg] $msg } {1 {can't read "a": no such variable}} test parse-11.4 {Tcl_EvalEx, error in Tcl_EvalObjv call} testevalex { - catch {unset a} + unset -nocomplain a list [catch {testevalex {_bogus_ a b c d}} msg] $msg } {1 {invalid command name "_bogus_"}} test parse-11.5 {Tcl_EvalEx, exceptional return} testevalex { @@ -564,7 +565,7 @@ test parse-11.8 {Tcl_EvalEx, multiple commands in script} testevalex { }] $a $c } {d b d} test parse-11.9 {Tcl_EvalEx, freeing memory after error} testevalex { - catch {unset a} + unset -nocomplain a list [catch {testevalex {concat a b c d e f g h i j k l m n o p q r s t u v w x y z $a}} msg] $msg } {1 {can't read "a": no such variable}} test parse-11.10 {Tcl_EvalTokens, empty commands} testevalex { @@ -670,11 +671,11 @@ test parse-13.3 {Tcl_ParseVar procedure, no variable name} testparsevar { testparsevar {$.123} } {{$} .123} test parse-13.4 {Tcl_ParseVar procedure, error looking up variable} testparsevar { - catch {unset abc} + unset -nocomplain abc list [catch {testparsevar {$abc}} msg] $msg } {1 {can't read "abc": no such variable}} test parse-13.5 {Tcl_ParseVar procedure, error looking up variable} testparsevar { - catch {unset abc} + unset -nocomplain abc list [catch {testparsevar {$abc([bogus x y z])}} msg] $msg } {1 {invalid command name "bogus"}} @@ -1090,6 +1091,13 @@ 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 {testevent delete a; set a [p]; set ::done $a} + proc ::p {} {string first s $::script} + testevent queue a head $::script + vwait done +} {} + cleanupTests } diff --git a/tests/parseExpr.test b/tests/parseExpr.test index d667bf2..9e2af18 100644 --- a/tests/parseExpr.test +++ b/tests/parseExpr.test @@ -8,10 +8,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 - namespace import -force ::tcltest::* -} +package require tcltest 2 +namespace import ::tcltest::* ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] @@ -1066,5 +1064,5 @@ test parseExpr-22.18 {Bug 3401704} -constraints testexprparser -body { # cleanup -::tcltest::cleanupTests +cleanupTests return diff --git a/tests/parseOld.test b/tests/parseOld.test index 0edcbf0..f3b1591 100644 --- a/tests/parseOld.test +++ b/tests/parseOld.test @@ -13,10 +13,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import -force ::tcltest::* -} +package require tcltest +namespace import ::tcltest::* ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] @@ -166,25 +164,25 @@ test parseOld-5.6 {variable substitution} { set msg } {can't read "_non_existent_": no such variable} test parseOld-5.7 {array variable substitution} { - catch {unset a} + unset -nocomplain a set a(xyz) 123 set b $a(xyz)foo set b } 123foo test parseOld-5.8 {array variable substitution} { - catch {unset a} + unset -nocomplain a set "a(x y z)" 123 set b $a(x y z)foo set b } 123foo test parseOld-5.9 {array variable substitution} { - catch {unset a}; catch {unset qqq} + unset -nocomplain a qqq set "a(x y z)" qqq set $a([format x]\ y [format z]) foo set qqq } foo test parseOld-5.10 {array variable substitution} { - catch {unset a} + unset -nocomplain a list [catch {set b $a(22)} msg] $msg } {1 {can't read "a(22)": no such variable}} test parseOld-5.11 {array variable substitution} { @@ -194,9 +192,9 @@ test parseOld-5.11 {array variable substitution} { test parseOld-5.12 {empty array name support} { list [catch {set b a$()} msg] $msg } {1 {can't read "()": no such variable}} -catch {unset a} +unset -nocomplain a test parseOld-5.13 {array variable substitution} { - catch {unset a} + unset -nocomplain a set long {This is a very long variable, long enough to cause storage \ allocation to occur in Tcl_ParseVar. If that storage isn't getting \ freed up correctly, then a core leak will occur when this test is \ @@ -211,13 +209,13 @@ test parseOld-5.13 {array variable substitution} { run. This text is probably beginning to sound like drivel, but I've \ run out of things to say and I need more characters still.}}} test parseOld-5.14 {array variable substitution} { - catch {unset a}; catch {unset b}; catch {unset a1} + unset -nocomplain a b a1 set a1(22) foo set a(foo) bar set b $a($a1(22)) set b } bar -catch {unset a}; catch {unset a1} +unset -nocomplain a a1 test parseOld-7.1 {backslash substitution} { set a "\a\c\n\]\}" diff --git a/tests/pkgMkIndex.test b/tests/pkgMkIndex.test index 0fe394e..84c82ce 100644 --- a/tests/pkgMkIndex.test +++ b/tests/pkgMkIndex.test @@ -8,10 +8,8 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 - namespace import -force ::tcltest::* -} +package require tcltest 2 +namespace import ::tcltest::* set fullPkgPath [makeDirectory pkg] @@ -45,7 +43,7 @@ proc pkgtest::parseArgs { args } { set a [lindex $args $iarg] if {[regexp {^-} $a]} { lappend options $a - if {[string compare -load $a] == 0} { + if {$a eq "-load"} { incr iarg lappend options [lindex $args $iarg] } @@ -81,7 +79,7 @@ proc pkgtest::parseIndex { filePath } { $slave eval { rename package package_original proc package { args } { - if {[string compare [lindex $args 0] ifneeded] == 0} { + if {[lindex $args 0] eq "ifneeded"} { set pkg [lindex $args 1] set ver [lindex $args 2] set ::PKGS($pkg:$ver) [lindex $args 3] @@ -111,9 +109,9 @@ proc pkgtest::parseIndex { filePath } { foreach k [lsort [array names P]] { lappend PKGS $k $P($k) } - } err]} { - set ei $::errorInfo - set ec $::errorCode + } err opts]} { + set ei [dict get $opts -errorinfo] + set ec [dict get $opts -errorcode] catch {interp delete $slave} diff --git a/tests/platform.test b/tests/platform.test index aab7c78..6596975 100644 --- a/tests/platform.test +++ b/tests/platform.test @@ -9,10 +9,14 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import -force ::tcltest::* -} +package require tcltest 2 + +namespace eval ::tcl::test::platform { + namespace import ::tcltest::testConstraint + namespace import ::tcltest::test + namespace import ::tcltest::cleanupTests + + variable ::tcl_platform ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] @@ -54,7 +58,10 @@ test platform-3.1 {CPU ID on Windows/UNIX} \ -result {^(?:AuthenticAMD|CentaurHauls|CyrixInstead|GenuineIntel)$} # cleanup -::tcltest::cleanupTests +cleanupTests + +} +namespace delete ::tcl::test::platform return # Local Variables: diff --git a/tests/reg.test b/tests/reg.test index a0ea850..b653d4b 100644 --- a/tests/reg.test +++ b/tests/reg.test @@ -513,7 +513,7 @@ expectMatch 9.40 eE {a[\\]b} "a\\b" "a\\b" expectMatch 9.41 bE {a[\\]b} "a\\b" "a\\b" expectError 9.42 - {a[\Z]b} EESCAPE expectMatch 9.43 & {a[[b]c} "a\[c" "a\[c" -expectMatch 9.44 EMP* {a[\u00fe-\u0507][\u00ff-\u0300]b} \ +expectMatch 9.44 M* "a\[\u00fe-\u0507\]\[\u00ff-\u0300\]b" \ "a\u0102\u02ffb" "a\u0102\u02ffb" @@ -624,25 +624,19 @@ expectMatch 13.12 P "a\\fb" "a\fb" "a\fb" expectMatch 13.13 P "a\\nb" "a\nb" "a\nb" expectMatch 13.14 P "a\\rb" "a\rb" "a\rb" expectMatch 13.15 P "a\\tb" "a\tb" "a\tb" -expectMatch 13.16 P "a\\u0008x" "a\bx" "a\bx" -expectMatch 13.17 P {a\u008x} "a\bx" "a\bx" -expectMatch 13.18 P "a\\u00088x" "a\b8x" "a\b8x" -expectMatch 13.19 P "a\\U00000008x" "a\bx" "a\bx" -expectMatch 13.20 P {a\U0000008x} "a\bx" "a\bx" +expectMatch 13.16 - "a\u0008x" "a\bx" "a\bx" +expectMatch 13.19 - "a\U00000008x" "a\bx" "a\bx" +expectMatch 13.20 - "a\U0000008x" "a\bx" "a\bx" expectMatch 13.21 P "a\\vb" "a\vb" "a\vb" expectMatch 13.22 MP "a\\x08x" "a\bx" "a\bx" expectError 13.23 - {a\xq} EESCAPE expectMatch 13.24 MP "a\\x08x" "a\bx" "a\bx" expectError 13.25 - {a\z} EESCAPE expectMatch 13.26 MP "a\\010b" "a\bb" "a\bb" -expectMatch 13.27 P "a\\U00001234x" "a\u1234x" "a\u1234x" -expectMatch 13.28 P {a\U00001234x} "a\u1234x" "a\u1234x" -expectMatch 13.29 P "a\\U0001234x" "a\u1234x" "a\u1234x" -expectMatch 13.30 P {a\U0001234x} "a\u1234x" "a\u1234x" -expectMatch 13.31 P "a\\U000012345x" "a\u12345x" "a\u12345x" -expectMatch 13.32 P {a\U000012345x} "a\u12345x" "a\u12345x" -expectMatch 13.33 P "a\\U1000000x" "a\ufffd0x" "a\ufffd0x" -expectMatch 13.34 P {a\U1000000x} "a\ufffd0x" "a\ufffd0x" +expectMatch 13.27 - "a\U00001234x" "a\u1234x" "a\u1234x" +expectMatch 13.29 - "a\U0001234x" "a\u1234x" "a\u1234x" +expectMatch 13.31 - "a\U000012345x" "a\u12345x" "a\u12345x" +expectMatch 13.33 - "a\U1000000x" "a\ufffd0x" "a\ufffd0x" doing 14 "back references" @@ -1080,6 +1074,81 @@ test reg-33.13 {Bug 1810264 - infinite loop} { test reg-33.14 {Bug 1810264 - super-expensive expression} nonPortable { regexp {(x{200}){200}$y} {x} } 0 +test reg-33.15 {Bug 3603557 - an "in the wild" RE} { + lindex [regexp -expanded -about { + ^TETRA_MODE_CMD # Message Type + ([[:blank:]]+) # Pad + (ETS_1_1|ETS_1_2|ETS_2_2) # SystemCode + ([[:blank:]]+) # Pad + (CONTINUOUS|CARRIER|MCCH|TRAFFIC) # SharingMode + ([[:blank:]]+) # Pad + ([[:digit:]]{1,2}) # ColourCode + ([[:blank:]]+) # Pad + (1|2|3|4|6|9|12|18) # TSReservedFrames + ([[:blank:]]+) # Pad + (PASS|TRUE|FAIL|FALSE) # UPlaneDTX + ([[:blank:]]+) # Pad + (PASS|TRUE|FAIL|FALSE) # Frame18Extension + ([[:blank:]]+) # Pad + ([[:digit:]]{1,4}) # MCC + ([[:blank:]]+) # Pad + ([[:digit:]]{1,5}) # MNC + ([[:blank:]]+) # Pad + (BOTH|BCAST|ENQRY|NONE) # NbrCellBcast + ([[:blank:]]+) # Pad + (UNKNOWN|LOW|MEDIUM|HIGH) # CellServiceLevel + ([[:blank:]]+) # Pad + (PASS|TRUE|FAIL|FALSE) # LateEntryInfo + ([[:blank:]]+) # Pad + (300|400) # FrequencyBand + ([[:blank:]]+) # Pad + (NORMAL|REVERSE) # ReverseOperation + ([[:blank:]]+) # Pad + (NONE|\+6\.25|\-6\.25|\+12\.5) # Offset + ([[:blank:]]+) # Pad + (10) # DuplexSpacing + ([[:blank:]]+) # Pad + ([[:digit:]]{1,4}) # MainCarrierNr + ([[:blank:]]+) # Pad + (0|1|2|3) # NrCSCCH + ([[:blank:]]+) # Pad + (15|20|25|30|35|40|45) # MSTxPwrMax + ([[:blank:]]+) # Pad + (\-125|\-120|\-115|\-110|\-105|\-100|\-95|\-90|\-85|\-80|\-75|\-70|\-65|\-60|\-55|\-50) + # RxLevAccessMin + ([[:blank:]]+) # Pad + (\-53|\-51|\-49|\-47|\-45|\-43|\-41|\-39|\-37|\-35|\-33|\-31|\-29|\-27|\-25|\-23) + # AccessParameter + ([[:blank:]]+) # Pad + (DISABLE|[[:digit:]]{3,4}) # RadioDLTimeout + ([[:blank:]]+) # Pad + (\-[[:digit:]]{2,3}) # RSSIThreshold + ([[:blank:]]+) # Pad + ([[:digit:]]{1,5}) # CCKIdSCKVerNr + ([[:blank:]]+) # Pad + ([[:digit:]]{1,5}) # LocationArea + ([[:blank:]]+) # Pad + ([(1|0)]{16}) # SubscriberClass + ([[:blank:]]+) # Pad + ([(1|0)]{12}) # BSServiceDetails + ([[:blank:]]+) # Pad + (RANDOMIZE|IMMEDIATE|[[:digit:]]{1,2}) # IMM + ([[:blank:]]+) # Pad + ([[:digit:]]{1,2}) # WT + ([[:blank:]]+) # Pad + ([[:digit:]]{1,2}) # Nu + ([[:blank:]]+) # Pad + ([0-1]) # FrameLngFctr + ([[:blank:]]+) # Pad + ([[:digit:]]{1,2}) # TSPtr + ([[:blank:]]+) # Pad + ([0-7]) # MinPriority + ([[:blank:]]+) # Pad + (PASS|TRUE|FAIL|FALSE) # ExtdSrvcsEnabled + ([[:blank:]]+) # Pad + (.*) # ConditionalFields + }] 0 +} 68 # cleanup ::tcltest::cleanupTests diff --git a/tests/regexp.test b/tests/regexp.test index 7cafd1b..2d2814a 100644 --- a/tests/regexp.test +++ b/tests/regexp.test @@ -819,6 +819,52 @@ test regexp-22.1 {Bug 1810038} { test regexp-22.2 {regexp compile and backrefs, Bug 1857126} { regexp -- {([bc])\1} bb } 1 +test regexp-22.3 {Bug 3604074} { + # This will hang in interps where the bug is not fixed + regexp ((((((((a)*)*)*)*)*)*)*)* a +} 1 +test regexp-22.4 {Bug 3606139} -setup { + interp alias {} a {} string repeat a +} -body { + # This crashes in interps where the bug is not fixed + regexp [join [list [a 160]([a 55])[a 668]([a 55])[a 669]([a 55]) \ + [a 668]([a 55])[a 649]([a 55])[a 668]([a 55])[a 668]([a 55]) \ + [a 672]([a 55])[a 669]([a 55])[a 671]([a 55])[a 671]([a 55]) \ + [a 672]([a 55])[a 652]([a 55])[a 672]([a 55])[a 671]([a 55]) \ + [a 671]([a 55])[a 671]([a 55])[a 653]([a 55])[a 672]([a 55]) \ + [a 653]([a 55])[a 672]([a 55])[a 672]([a 55])[a 652]([a 55]) \ + [a 671]([a 55])[a 652]([a 55])[a 652]([a 55])[a 672]([a 55]) \ + [a 672]([a 55])[a 672]([a 55])[a 653]([a 55])[a 671]([a 55]) \ + [a 669]([a 55])[a 649]([a 55])[a 668]([a 55])[a 668]([a 55]) \ + [a 668]([a 55])[a 650]([a 55])[a 650]([a 55])[a 672]([a 55]) \ + [a 669]([a 55])[a 669]([a 55])[a 668]([a 55])[a 668]([a 55]) \ + [a 668]([a 55])[a 669]([a 55])[a 672]([a 55])[a 669]([a 55]) \ + [a 669]([a 55])[a 669]([a 55])[a 669]([a 55])[a 672]([a 55]) \ + [a 670]([a 55])[a 671]([a 55])[a 672]([a 55])[a 672]([a 55]) \ + [a 671]([a 55])[a 671]([a 55])[a 672]([a 55])[a 669]([a 55]) \ + [a 668]([a 55])[a 668]([a 55])[a 669]([a 55])[a 668]([a 55]) \ + [a 669]([a 55])[a 668]([a 55])[a 669]([a 55])[a 669]([a 55]) \ + [a 668]([a 55])[a 668]([a 55])[a 669]([a 55])[a 668]([a 55]) \ + [a 669]([a 55])[a 669]([a 55])[a 669]([a 55])[a 669]([a 55]) \ + [a 668]([a 55])[a 669]([a 55])[a 672]([a 55])[a 669]([a 55]) \ + [a 669]([a 55])[a 669]([a 55])[a 669]([a 55])[a 668]([a 55]) \ + [a 669]([a 55])[a 669]([a 55])[a 668]([a 55])[a 668]([a 55]) \ + [a 668]([a 55])[a 669]([a 55])[a 668]([a 55])[a 669]([a 55]) \ + [a 672]([a 55])[a 669]([a 55])[a 669]([a 55])[a 710]([a 55]) \ + [a 668]([a 55])[a 669]([a 55])[a 668]([a 55])[a 669]([a 55]) \ + [a 668]([a 55])[a 669]([a 55])[a 668]([a 55])[a 668]([a 55]) \ + [a 668]([a 55])[a 668]([a 55])[a 668]([a 55])[a 669]([a 55]) \ + [a 672]([a 55])[a 669]([a 55])[a 669]([a 55])[a 668]([a 55]) \ + [a 669]([a 55])[a 669]([a 55])[a 668]([a 55])[a 668]([a 55]) \ + [a 668]([a 55])[a 668]([a 55])[a 668]([a 55])[a 668]([a 55]) \ + [a 667]([a 55])[a 668]([a 55])[a 669]([a 55])[a 668]([a 55]) \ + [a 671]([a 55])[a 669]([a 55])[a 668]([a 55])[a 669]([a 55]) \ + [a 669]([a 55])[a 669]([a 55])[a 668]([a 55])[a 669]([a 55]) \ + [a 668]([a 55])[a 710]([a 55])[a 668]([a 55])[a 668]([a 55]) \ + [a 668]([a 55])[a 668]([a 55])[a 668]([a 55])[a 511]] {}] a +} -cleanup { + rename a {} +} -returnCodes 1 -result {couldn't compile regular expression pattern: nfa has too many states} test regexp-23.1 {regexp -all and -line} { set string "" diff --git a/tests/result.test b/tests/result.test index 3391ce1..9e8a66b 100644 --- a/tests/result.test +++ b/tests/result.test @@ -10,10 +10,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 - namespace import -force ::tcltest::* -} +package require tcltest 2 +namespace import ::tcltest::* ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] diff --git a/tests/set.test b/tests/set.test index 1d88553..18119f5 100644 --- a/tests/set.test +++ b/tests/set.test @@ -524,6 +524,11 @@ test set-5.1 {error on malformed array name} testset2 { list $msg $msg1 } {{can't read "z(a)(b)": variable isn't array} {can't read "z(b)(a)": variable isn't array}} +# In a mem-debug build, this test will crash unless Bug 3602706 is fixed. +test set-5.2 {Bug 3602706} -body { + testset2 ::tcl_platform not-in-there +} -returnCodes error -result * -match glob + # cleanup catch {unset a} catch {unset b} diff --git a/tests/stack.test b/tests/stack.test index 873cb08..13bc524 100644 --- a/tests/stack.test +++ b/tests/stack.test @@ -9,10 +9,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 - namespace import -force ::tcltest::* -} +package require tcltest 2 +namespace import ::tcltest::* # Note that a failure in this test may result in a crash of the executable. diff --git a/tests/tcltest.test b/tests/tcltest.test index 86aca6f..ce8d617 100755 --- a/tests/tcltest.test +++ b/tests/tcltest.test @@ -80,10 +80,7 @@ proc slave {msgVar args} { # Need to capture output in msg - set code [catch {i eval {source $argv0}} foo] -if $code { -#puts "$code: $foo\n$::errorInfo" -} + set code [catch {i eval {source $argv0}}] i eval {close $tcltest::outputChannel} interp delete [namespace current]::i set f [open $of] @@ -99,8 +96,6 @@ if $code { append msg \n$err } return $code - -# return [catch {uplevel 1 [linsert $args 0 exec [interpreter]]} msg] } test tcltest-2.0 {tcltest (verbose default - 'b')} {unixOrPc} { set result [slave msg test.tcl] @@ -549,7 +544,7 @@ set notWriteableDir [file join [temporaryDirectory] notwriteable] makeDirectory notreadable makeDirectory notwriteable switch -- $::tcl_platform(platform) { - "unix" { + unix { file attributes $notReadableDir -permissions 00333 file attributes $notWriteableDir -permissions 00555 } @@ -716,8 +711,8 @@ test tcltest-8.60 {::workingDirectory} { # clean up from directory testing -switch $::tcl_platform(platform) { - "unix" { +switch -- $::tcl_platform(platform) { + unix { file attributes $notReadableDir -permissions 777 file attributes $notWriteableDir -permissions 777 } @@ -727,7 +722,7 @@ switch $::tcl_platform(platform) { } } -file delete -force $notReadableDir $notWriteableDir +file delete -force -- $notReadableDir $notWriteableDir removeFile a.tcl removeFile thisdirectoryisafile removeDirectory normaldirectory @@ -1150,7 +1145,7 @@ test tcltest-19.1 {TCLTEST_OPTIONS default} -setup { } -cleanup { interp delete slave2 interp delete slave1 - if {$oldoptions == "none"} { + if {$oldoptions eq "none"} { unset ::env(TCLTEST_OPTIONS) } else { set ::env(TCLTEST_OPTIONS) $oldoptions diff --git a/tests/thread.test b/tests/thread.test index d79f693..f32ef61 100644 --- a/tests/thread.test +++ b/tests/thread.test @@ -84,28 +84,6 @@ if {[testConstraint testthread]} { } testthread errorproc ThreadError - - set mainThread [testthread id] - - proc ThreadNullError {id info} { - # ignore - } - - proc threadReap {} { - testthread errorproc ThreadNullError - while {[llength [testthread names]] > 1} { - foreach tid [testthread names] { - if {$tid != [testthread id]} { - catch { - testthread send -async $tid {testthread exit} - } - } - } - after 1 - } - testthread errorproc ThreadError - return [llength [testthread names]] - } } # Some tests require manual draining of the event queue diff --git a/tests/tm.test b/tests/tm.test index 73e8261..280b058 100644 --- a/tests/tm.test +++ b/tests/tm.test @@ -200,8 +200,13 @@ test tm-3.11 {tm: module path management, remove ignores unknown path} -setup { proc genpaths {base} { # Normalizing picks up drive letters on windows [Bug 1053568] set base [file normalize $base] - foreach {major minor} [split [info tclversion] .] break + lassign [split [package present Tcl] .] major minor set results {} + set base8 [file join $base tcl8] + lappend results [file join $base8 site-tcl] + for {set i 0} {$i <= 7} {incr i} { + lappend results [file join $base8 8.$i] + } set base [file join $base tcl$major] lappend results [file join $base site-tcl] for {set i 0} {$i <= $minor} {incr i} { diff --git a/tests/trace.test b/tests/trace.test index 0f48dcf..41ad00d 100644 --- a/tests/trace.test +++ b/tests/trace.test @@ -11,10 +11,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import -force ::tcltest::* -} +package require tcltest +namespace import ::tcltest::* ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] @@ -32,15 +30,15 @@ proc getbytes {} { proc traceScalar {name1 name2 op} { global info - set info [list $name1 $name2 $op [catch {uplevel set $name1} msg] $msg] + set info [list $name1 $name2 $op [catch {uplevel 1 set $name1} msg] $msg] } proc traceScalarAppend {name1 name2 op} { global info - lappend info $name1 $name2 $op [catch {uplevel set $name1} msg] $msg + lappend info $name1 $name2 $op [catch {uplevel 1 set $name1} msg] $msg } proc traceArray {name1 name2 op} { global info - set info [list $name1 $name2 $op [catch {uplevel set [set name1]($name2)} msg] $msg] + set info [list $name1 $name2 $op [catch {uplevel 1 set [set name1]($name2)} msg] $msg] } proc traceArray2 {name1 name2 op} { global info @@ -62,7 +60,7 @@ proc traceCheck {cmd args} { set info [list [catch $cmd msg] $msg] } proc traceCrtElement {value name1 name2 op} { - uplevel set ${name1}($name2) $value + uplevel 1 set ${name1}($name2) $value } proc traceCommand {oldName newName op} { global info @@ -72,10 +70,10 @@ proc traceCommand {oldName newName op} { test trace-0.0 {memory corruption in trace (Tcl Bug 484339)} { # You may need Purify or Electric Fence to reliably # see this one fail. - catch {unset z} + unset -nocomplain z trace add variable z array {set z(foo) 1 ;#} set res "names: [array names z]" - catch {unset ::z} + unset -nocomplain ::z trace variable ::z w {unset ::z; error "memory corruption";#} list [catch {set ::z 1} msg] $msg } {1 {can't set "::z": memory corruption}} @@ -83,40 +81,40 @@ test trace-0.0 {memory corruption in trace (Tcl Bug 484339)} { # Read-tracing on variables test trace-1.1 {trace variable reads} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x read traceScalar list [catch {set x} msg] $msg $info } {1 {can't read "x": no such variable} {x {} read 1 {can't read "x": no such variable}}} test trace-1.2 {trace variable reads} { - catch {unset x} + unset -nocomplain x set x 123 set info {} trace add variable x read traceScalar list [catch {set x} msg] $msg $info } {0 123 {x {} read 0 123}} test trace-1.3 {trace variable reads} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x read traceScalar set x 123 set info } {} test trace-1.4 {trace array element reads} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x(2) read traceArray list [catch {set x(2)} msg] $msg $info } {1 {can't read "x(2)": no such element in array} {x 2 read 1 {can't read "x(2)": no such element in array}}} test trace-1.5 {trace array element reads} { - catch {unset x} + unset -nocomplain x set x(2) zzz set info {} trace add variable x(2) read traceArray list [catch {set x(2)} msg] $msg $info } {0 zzz {x 2 read 0 zzz}} test trace-1.6 {trace array element reads} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x read traceArray2 proc p {} { @@ -127,7 +125,7 @@ test trace-1.6 {trace array element reads} { list [catch {p} msg] $msg $info } {0 willi {x 2 read}} test trace-1.7 {trace array element reads, create element undefined if nonexistant} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x read q proc q {name1 name2 op} { @@ -144,20 +142,20 @@ test trace-1.7 {trace array element reads, create element undefined if nonexista list [catch {p} msg] $msg $info } {0 wolf {x Y read}} test trace-1.8 {trace reads on whole arrays} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x read traceArray list [catch {set x(2)} msg] $msg $info } {1 {can't read "x(2)": no such variable} {}} test trace-1.9 {trace reads on whole arrays} { - catch {unset x} + unset -nocomplain x set x(2) zzz set info {} trace add variable x read traceArray list [catch {set x(2)} msg] $msg $info } {0 zzz {x 2 read 0 zzz}} test trace-1.10 {trace variable reads} { - catch {unset x} + unset -nocomplain x set x 444 set info {} trace add variable x read traceScalar @@ -165,28 +163,28 @@ test trace-1.10 {trace variable reads} { set info } {} test trace-1.11 {read traces that modify the array structure} { - catch {unset x} + unset -nocomplain x set x(bar) 0 trace variable x r {set x(foo) 1 ;#} trace variable x r {unset -nocomplain x(bar) ;#} array get x } {} test trace-1.12 {read traces that modify the array structure} { - catch {unset x} + unset -nocomplain x set x(bar) 0 trace variable x r {unset -nocomplain x(bar) ;#} trace variable x r {set x(foo) 1 ;#} array get x } {} test trace-1.13 {read traces that modify the array structure} { - catch {unset x} + unset -nocomplain x set x(bar) 0 trace variable x r {set x(foo) 1 ;#} trace variable x r {unset -nocomplain x;#} list [catch {array get x} res] $res } {1 {can't read "x(bar)": no such variable}} test trace-1.14 {read traces that modify the array structure} { - catch {unset x} + unset -nocomplain x set x(bar) 0 trace variable x r {unset -nocomplain x;#} trace variable x r {set x(foo) 1 ;#} @@ -196,28 +194,28 @@ test trace-1.14 {read traces that modify the array structure} { # Basic write-tracing on variables test trace-2.1 {trace variable writes} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x write traceScalar set x 123 set info } {x {} write 0 123} test trace-2.2 {trace writes to array elements} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x(33) write traceArray set x(33) 444 set info } {x 33 write 0 444} test trace-2.3 {trace writes on whole arrays} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x write traceArray set x(abc) qq set info } {x abc write 0 qq} test trace-2.4 {trace variable writes} { - catch {unset x} + unset -nocomplain x set x 1234 set info {} trace add variable x write traceScalar @@ -225,7 +223,7 @@ test trace-2.4 {trace variable writes} { set info } {} test trace-2.5 {trace variable writes} { - catch {unset x} + unset -nocomplain x set x 1234 set info {} trace add variable x write traceScalar @@ -238,7 +236,7 @@ test trace-2.6 {trace variable writes on compiled local} { # arrays [Bug 1770591]. The corresponding function for read traces is # already indirectly tested in trace-1.7 # - catch {unset x} + unset -nocomplain x set info {} proc p {} { trace add variable x write traceArray @@ -267,7 +265,7 @@ test trace-2.7 {trace variable writes on errorInfo} -body { # trace: after appending all arguments to the list. test trace-3.1 {trace variable read-modify-writes} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x read traceScalarAppend append x 123 @@ -276,7 +274,7 @@ test trace-3.1 {trace variable read-modify-writes} { set info } {x {} read 0 123456} test trace-3.2 {trace variable read-modify-writes} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x {read write} traceScalarAppend append x 123 @@ -287,14 +285,14 @@ test trace-3.2 {trace variable read-modify-writes} { # Basic unset-tracing on variables test trace-4.1 {trace variable unsets} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x unset traceScalar - catch {unset x} + unset -nocomplain x set info } {x {} unset 1 {can't read "x": no such variable}} test trace-4.2 {variable mustn't exist during unset trace} { - catch {unset x} + unset -nocomplain x set x 1234 set info {} trace add variable x unset traceScalar @@ -302,7 +300,7 @@ test trace-4.2 {variable mustn't exist during unset trace} { set info } {x {} unset 1 {can't read "x": no such variable}} test trace-4.3 {unset traces mustn't be called during reads and writes} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x unset traceScalar set x 44 @@ -310,15 +308,15 @@ test trace-4.3 {unset traces mustn't be called during reads and writes} { set info } {} test trace-4.4 {trace unsets on array elements} { - catch {unset x} + unset -nocomplain x set x(0) 18 set info {} trace add variable x(1) unset traceArray - catch {unset x(1)} + unset -nocomplain x(1) set info } {x 1 unset 1 {can't read "x(1)": no such element in array}} test trace-4.5 {trace unsets on array elements} { - catch {unset x} + unset -nocomplain x set x(1) 18 set info {} trace add variable x(1) unset traceArray @@ -326,7 +324,7 @@ test trace-4.5 {trace unsets on array elements} { set info } {x 1 unset 1 {can't read "x(1)": no such element in array}} test trace-4.6 {trace unsets on array elements} { - catch {unset x} + unset -nocomplain x set x(1) 18 set info {} trace add variable x(1) unset traceArray @@ -334,15 +332,15 @@ test trace-4.6 {trace unsets on array elements} { set info } {x 1 unset 1 {can't read "x(1)": no such variable}} test trace-4.7 {trace unsets on whole arrays} { - catch {unset x} + unset -nocomplain x set x(1) 18 set info {} trace add variable x unset traceProc - catch {unset x(0)} + unset -nocomplain x(0) set info } {} test trace-4.8 {trace unsets on whole arrays} { - catch {unset x} + unset -nocomplain x set x(1) 18 set x(2) 144 set x(3) 14 @@ -352,7 +350,7 @@ test trace-4.8 {trace unsets on whole arrays} { set info } {x 1 unset} test trace-4.9 {trace unsets on whole arrays} { - catch {unset x} + unset -nocomplain x set x(1) 18 set x(2) 144 set x(3) 14 @@ -364,7 +362,7 @@ test trace-4.9 {trace unsets on whole arrays} { # Array tracing on variables test trace-5.1 {array traces fire on accesses via [array]} { - catch {unset x} + unset -nocomplain x set x(b) 2 trace add variable x array traceArray2 set ::info {} @@ -372,7 +370,7 @@ test trace-5.1 {array traces fire on accesses via [array]} { set ::info } {x {} array} test trace-5.2 {array traces do not fire on normal accesses} { - catch {unset x} + unset -nocomplain x set x(b) 2 trace add variable x array traceArray2 set ::info {} @@ -381,7 +379,7 @@ test trace-5.2 {array traces do not fire on normal accesses} { set ::info } {} test trace-5.3 {array traces do not outlive variable} { - catch {unset x} + unset -nocomplain x trace add variable x array traceArray2 set ::info {} set x(a) 1 @@ -390,19 +388,19 @@ test trace-5.3 {array traces do not outlive variable} { set ::info } {} test trace-5.4 {array traces properly listed in trace information} { - catch {unset x} + unset -nocomplain x trace add variable x array traceArray2 set result [trace info variable x] set result } [list [list array traceArray2]] test trace-5.5 {array traces properly listed in trace information} { - catch {unset x} + unset -nocomplain x trace variable x a traceArray2 set result [trace vinfo x] set result } [list [list a traceArray2]] test trace-5.6 {array traces don't fire on scalar variables} { - catch {unset x} + unset -nocomplain x set x foo trace add variable x array traceArray2 set ::info {} @@ -410,14 +408,14 @@ test trace-5.6 {array traces don't fire on scalar variables} { set ::info } {} test trace-5.7 {array traces fire for undefined variables} { - catch {unset x} + unset -nocomplain x trace add variable x array traceArray2 set ::info {} array set x {a 1} set ::info } {x {} array} test trace-5.8 {array traces fire for undefined variables} { - catch {unset x} + unset -nocomplain x trace add variable x array {set x(foo) 1 ;#} set res "names: [array names x]" } {names: foo} @@ -425,7 +423,7 @@ test trace-5.8 {array traces fire for undefined variables} { # Trace multiple trace types at once. test trace-6.1 {multiple ops traced at once} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x {read write unset} traceProc catch {set x} @@ -436,7 +434,7 @@ test trace-6.1 {multiple ops traced at once} { set info } {x {} read x {} write x {} read x {} write x {} unset} test trace-6.2 {multiple ops traced on array element} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x(0) {read write unset} traceProc catch {set x(0)} @@ -448,7 +446,7 @@ test trace-6.2 {multiple ops traced on array element} { set info } {x 0 read x 0 write x 0 read x 0 write x 0 unset} test trace-6.3 {multiple ops traced on whole array} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x {read write unset} traceProc catch {set x(0)} @@ -463,7 +461,7 @@ test trace-6.3 {multiple ops traced on whole array} { # Check order of invocation of traces test trace-7.1 {order of invocation of traces} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x read "traceTag 1" trace add variable x read "traceTag 2" @@ -474,7 +472,7 @@ test trace-7.1 {order of invocation of traces} { set info } {3 2 1 3 2 1} test trace-7.2 {order of invocation of traces} { - catch {unset x} + unset -nocomplain x set x(0) 44 set info {} trace add variable x(0) read "traceTag 1" @@ -484,7 +482,7 @@ test trace-7.2 {order of invocation of traces} { set info } {3 2 1} test trace-7.3 {order of invocation of traces} { - catch {unset x} + unset -nocomplain x set x(0) 44 set info {} trace add variable x(0) read "traceTag 1" @@ -500,7 +498,7 @@ test trace-7.3 {order of invocation of traces} { # Check effects of errors in trace procedures test trace-8.1 {error returns from traces} { - catch {unset x} + unset -nocomplain x set x 123 set info {} trace add variable x read "traceTag 1" @@ -508,7 +506,7 @@ test trace-8.1 {error returns from traces} { list [catch {set x} msg] $msg $info } {1 {can't read "x": trace returned error} {}} test trace-8.2 {error returns from traces} { - catch {unset x} + unset -nocomplain x set x 123 set info {} trace add variable x write "traceTag 1" @@ -516,14 +514,14 @@ test trace-8.2 {error returns from traces} { list [catch {set x 44} msg] $msg $info } {1 {can't set "x": trace returned error} {}} test trace-8.3 {error returns from traces} { - catch {unset x} + unset -nocomplain x set x 123 set info {} trace add variable x write traceError list [catch {append x 44} msg] $msg $info } {1 {can't set "x": trace returned error} {}} test trace-8.4 {error returns from traces} { - catch {unset x} + unset -nocomplain x set x 123 set info {} trace add variable x unset "traceTag 1" @@ -531,7 +529,7 @@ test trace-8.4 {error returns from traces} { list [catch {unset x} msg] $msg $info } {0 {} 1} test trace-8.5 {error returns from traces} { - catch {unset x} + unset -nocomplain x set x(0) 123 set info {} trace add variable x(0) read "traceTag 1" @@ -541,7 +539,7 @@ test trace-8.5 {error returns from traces} { list [catch {set x(0)} msg] $msg $info } {1 {can't read "x(0)": trace returned error} 3} test trace-8.6 {error returns from traces} { - catch {unset x} + unset -nocomplain x set x 123 trace add variable x unset traceError list [catch {unset x} msg] $msg @@ -550,7 +548,7 @@ test trace-8.7 {error returns from traces} { # This test just makes sure that the memory for the error message # gets deallocated correctly when the trace is invoked again or # when the trace is deleted. - catch {unset x} + unset -nocomplain x set x 123 trace add variable x read traceError catch {set x} @@ -571,7 +569,7 @@ test trace-8.8 {error returns from traces} { trace add variable ::x write [list foo $::x] error "foo" } - catch {unset ::x ::y} + unset -nocomplain ::x ::y set x junk trace add variable ::x write [list foo $x] for {set y 0} {$y<100} {incr y} { @@ -585,31 +583,31 @@ test trace-8.8 {error returns from traces} { # a new copy of the variables. test trace-9.1 {be sure variable is unset before trace is called} { - catch {unset x} + unset -nocomplain x set x 33 set info {} - trace add variable x unset {traceCheck {uplevel set x}} + trace add variable x unset {traceCheck {uplevel 1 set x}} unset x set info } {1 {can't read "x": no such variable}} test trace-9.2 {be sure variable is unset before trace is called} { - catch {unset x} + unset -nocomplain x set x 33 set info {} - trace add variable x unset {traceCheck {uplevel set x 22}} + trace add variable x unset {traceCheck {uplevel 1 set x 22}} unset x concat $info [list [catch {set x} msg] $msg] } {0 22 0 22} test trace-9.3 {be sure traces are cleared before unset trace called} { - catch {unset x} + unset -nocomplain x set x 33 set info {} - trace add variable x unset {traceCheck {uplevel trace info variable x}} + trace add variable x unset {traceCheck {uplevel 1 trace info variable x}} unset x set info } {0 {}} test trace-9.4 {set new trace during unset trace} { - catch {unset x} + unset -nocomplain x set x 33 set info {} trace add variable x unset {traceCheck {global x; trace add variable x unset traceProc}} @@ -618,23 +616,23 @@ test trace-9.4 {set new trace during unset trace} { } {0 {} {unset traceProc}} test trace-10.1 {make sure array elements are unset before traces are called} { - catch {unset x} + unset -nocomplain x set x(0) 33 set info {} - trace add variable x(0) unset {traceCheck {uplevel set x(0)}} + trace add variable x(0) unset {traceCheck {uplevel 1 set x(0)}} unset x(0) set info } {1 {can't read "x(0)": no such element in array}} test trace-10.2 {make sure array elements are unset before traces are called} { - catch {unset x} + unset -nocomplain x set x(0) 33 set info {} - trace add variable x(0) unset {traceCheck {uplevel set x(0) zzz}} + trace add variable x(0) unset {traceCheck {uplevel 1 set x(0) zzz}} unset x(0) concat $info [list [catch {set x(0)} msg] $msg] } {0 zzz 0 zzz} test trace-10.3 {array elements are unset before traces are called} { - catch {unset x} + unset -nocomplain x set x(0) 33 set info {} trace add variable x(0) unset {traceCheck {global x; trace info variable x(0)}} @@ -642,49 +640,49 @@ test trace-10.3 {array elements are unset before traces are called} { set info } {0 {}} test trace-10.4 {set new array element trace during unset trace} { - catch {unset x} + unset -nocomplain x set x(0) 33 set info {} - trace add variable x(0) unset {traceCheck {uplevel {trace add variable x(0) read {}}}} - catch {unset x(0)} + trace add variable x(0) unset {traceCheck {uplevel 1 {trace add variable x(0) read {}}}} + unset -nocomplain x(0) concat $info [trace info variable x(0)] } {0 {} {read {}}} test trace-11.1 {make sure arrays are unset before traces are called} { - catch {unset x} + unset -nocomplain x set x(0) 33 set info {} - trace add variable x unset {traceCheck {uplevel set x(0)}} + trace add variable x unset {traceCheck {uplevel 1 set x(0)}} unset x set info } {1 {can't read "x(0)": no such variable}} test trace-11.2 {make sure arrays are unset before traces are called} { - catch {unset x} + unset -nocomplain x set x(y) 33 set info {} - trace add variable x unset {traceCheck {uplevel set x(y) 22}} + trace add variable x unset {traceCheck {uplevel 1 set x(y) 22}} unset x concat $info [list [catch {set x(y)} msg] $msg] } {0 22 0 22} test trace-11.3 {make sure arrays are unset before traces are called} { - catch {unset x} + unset -nocomplain x set x(y) 33 set info {} - trace add variable x unset {traceCheck {uplevel array exists x}} + trace add variable x unset {traceCheck {uplevel 1 array exists x}} unset x set info } {0 0} test trace-11.4 {make sure arrays are unset before traces are called} { - catch {unset x} + unset -nocomplain x set x(y) 33 set info {} - set cmd {traceCheck {uplevel {trace info variable x}}} + set cmd {traceCheck {uplevel 1 {trace info variable x}}} trace add variable x unset $cmd unset x set info } {0 {}} test trace-11.5 {set new array trace during unset trace} { - catch {unset x} + unset -nocomplain x set x(y) 33 set info {} trace add variable x unset {traceCheck {global x; trace add variable x read {}}} @@ -692,7 +690,7 @@ test trace-11.5 {set new array trace during unset trace} { concat $info [trace info variable x] } {0 {} {read {}}} test trace-11.6 {create scalar during array unset trace} { - catch {unset x} + unset -nocomplain x set x(y) 33 set info {} trace add variable x unset {traceCheck {global x; set x 44}} @@ -703,52 +701,52 @@ test trace-11.6 {create scalar during array unset trace} { # Check special conditions (e.g. errors) in Tcl_TraceVar2. test trace-12.1 {creating array when setting variable traces} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x(0) write traceProc list [catch {set x 22} msg] $msg } {1 {can't set "x": variable is array}} test trace-12.2 {creating array when setting variable traces} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x(0) write traceProc list [catch {set x(0)} msg] $msg } {1 {can't read "x(0)": no such element in array}} test trace-12.3 {creating array when setting variable traces} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x(0) write traceProc set x(0) 22 set info } {x 0 write} test trace-12.4 {creating variable when setting variable traces} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x write traceProc list [catch {set x} msg] $msg } {1 {can't read "x": no such variable}} test trace-12.5 {creating variable when setting variable traces} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x write traceProc set x 22 set info } {x {} write} test trace-12.6 {creating variable when setting variable traces} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x write traceProc set x(0) 22 set info } {x 0 write} test trace-12.7 {create array element during read trace} { - catch {unset x} + unset -nocomplain x set x(2) zzz trace add variable x read {traceCrtElement xyzzy} list [catch {set x(3)} msg] $msg } {0 xyzzy} test trace-12.8 {errors when setting variable traces} { - catch {unset x} + unset -nocomplain x set x 44 list [catch {trace add variable x(0) write traceProc} msg] $msg } {1 {can't trace "x(0)": variable isn't array}} @@ -762,7 +760,7 @@ test trace-13.1 {delete one trace from another} { trace remove variable x read {traceTag 3} trace remove variable x read {traceTag 4} } - catch {unset x} + unset -nocomplain x set x 44 set info {} trace add variable x read {traceTag 1} @@ -916,13 +914,13 @@ test trace-14.11 {trace command, "trace variable" errors} { test trace-14.12 {trace command ("remove variable" option)} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x write traceProc trace remove variable x write traceProc } {} test trace-14.13 {trace command ("remove variable" option)} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x write traceProc trace remove variable x write traceProc @@ -930,7 +928,7 @@ test trace-14.13 {trace command ("remove variable" option)} { set info } {} test trace-14.14 {trace command ("remove variable" option)} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x write {traceTag 1} trace add variable x write traceProc @@ -945,7 +943,7 @@ test trace-14.14 {trace command ("remove variable" option)} { set info } {2 x {} write 1 2 1 2} test trace-14.15 {trace command ("remove variable" option)} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x write {traceTag 1} trace remove variable x write non_existent @@ -953,27 +951,27 @@ test trace-14.15 {trace command ("remove variable" option)} { set info } {1} test trace-14.16 {trace command ("info variable" option)} { - catch {unset x} + unset -nocomplain x trace add variable x write {traceTag 1} trace add variable x write traceProc trace add variable x write {traceTag 2} trace info variable x } {{write {traceTag 2}} {write traceProc} {write {traceTag 1}}} test trace-14.17 {trace command ("info variable" option)} { - catch {unset x} + unset -nocomplain x trace info variable x } {} test trace-14.18 {trace command ("info variable" option)} { - catch {unset x} + unset -nocomplain x trace info variable x(0) } {} test trace-14.19 {trace command ("info variable" option)} { - catch {unset x} + unset -nocomplain x set x 44 trace info variable x(0) } {} test trace-14.20 {trace command ("info variable" option)} { - catch {unset x} + unset -nocomplain x set x 44 trace add variable x write {traceTag 1} proc check {} {global x; trace info variable x} @@ -983,7 +981,7 @@ test trace-14.20 {trace command ("info variable" option)} { # Check fancy trace commands (long ones, weird arguments, etc.) test trace-15.1 {long trace command} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x write {traceTag {This is a very very long argument. It's \ designed to test out the facilities of TraceVarProc for dealing \ @@ -1001,14 +999,14 @@ test trace-15.2 {long trace command result to ignore} { proc longResult {args} {return "quite a bit of text, designed to generate a core leak if this command file is invoked over and over again and memory isn't being recycled correctly"} - catch {unset x} + unset -nocomplain x trace add variable x write longResult set x 44 set x 5 set x abcde } abcde test trace-15.3 {special list-handling in trace commands} { - catch {unset "x y z"} + unset -nocomplain "x y z" set "x y z(a\n\{)" 44 set info {} trace add variable "x y z(a\n\{)" write traceProc @@ -1020,18 +1018,18 @@ test trace-15.3 {special list-handling in trace commands} { proc traceUnset {unsetName args} { global info - upvar $unsetName x + upvar 1 $unsetName x lappend info [catch {unset x} msg] $msg [catch {set x} msg] $msg } proc traceReset {unsetName resetName args} { global info - upvar $unsetName x $resetName y + upvar 1 $unsetName x $resetName y lappend info [catch {unset x} msg] $msg [catch {set y xyzzy} msg] $msg } proc traceReset2 {unsetName resetName args} { global info - lappend info [catch {uplevel unset $unsetName} msg] $msg \ - [catch {uplevel set $resetName xyzzy} msg] $msg + lappend info [catch {uplevel 1 unset $unsetName} msg] $msg \ + [catch {uplevel 1 set $resetName xyzzy} msg] $msg } proc traceAppend {string name1 name2 op} { global info @@ -1039,7 +1037,7 @@ proc traceAppend {string name1 name2 op} { } test trace-16.1 {unsets during read traces} { - catch {unset y} + unset -nocomplain y set y 1234 set info {} trace add variable y read {traceUnset y} @@ -1047,49 +1045,49 @@ test trace-16.1 {unsets during read traces} { lappend info [catch {set y} msg] $msg } {unset 0 {} 1 {can't read "x": no such variable} 1 {can't read "y": no such variable}} test trace-16.2 {unsets during read traces} { - catch {unset y} + unset -nocomplain y set y(0) 1234 set info {} trace add variable y(0) read {traceUnset y(0)} lappend info [catch {set y(0)} msg] $msg } {0 {} 1 {can't read "x": no such variable} 1 {can't read "y(0)": no such element in array}} test trace-16.3 {unsets during read traces} { - catch {unset y} + unset -nocomplain y set y(0) 1234 set info {} trace add variable y(0) read {traceUnset y} lappend info [catch {set y(0)} msg] $msg } {0 {} 1 {can't read "x": no such variable} 1 {can't read "y(0)": no such variable}} test trace-16.4 {unsets during read traces} { - catch {unset y} + unset -nocomplain y set y 1234 set info {} trace add variable y read {traceReset y y} lappend info [catch {set y} msg] $msg } {0 {} 0 xyzzy 0 xyzzy} test trace-16.5 {unsets during read traces} { - catch {unset y} + unset -nocomplain y set y(0) 1234 set info {} trace add variable y(0) read {traceReset y(0) y(0)} lappend info [catch {set y(0)} msg] $msg } {0 {} 0 xyzzy 0 xyzzy} test trace-16.6 {unsets during read traces} { - catch {unset y} + unset -nocomplain y set y(0) 1234 set info {} trace add variable y(0) read {traceReset y y(0)} lappend info [catch {set y(0)} msg] $msg [catch {set y(0)} msg] $msg } {0 {} 1 {can't set "y": upvar refers to element in deleted array} 1 {can't read "y(0)": no such variable} 1 {can't read "y(0)": no such variable}} test trace-16.7 {unsets during read traces} { - catch {unset y} + unset -nocomplain y set y(0) 1234 set info {} trace add variable y(0) read {traceReset2 y y(0)} lappend info [catch {set y(0)} msg] $msg [catch {set y(0)} msg] $msg } {0 {} 0 xyzzy 1 {can't read "y(0)": no such element in array} 0 xyzzy} test trace-16.8 {unsets during write traces} { - catch {unset y} + unset -nocomplain y set y 1234 set info {} trace add variable y write {traceUnset y} @@ -1097,91 +1095,91 @@ test trace-16.8 {unsets during write traces} { lappend info [catch {set y xxx} msg] $msg } {unset 0 {} 1 {can't read "x": no such variable} 0 {}} test trace-16.9 {unsets during write traces} { - catch {unset y} + unset -nocomplain y set y(0) 1234 set info {} trace add variable y(0) write {traceUnset y(0)} lappend info [catch {set y(0) xxx} msg] $msg } {0 {} 1 {can't read "x": no such variable} 0 {}} test trace-16.10 {unsets during write traces} { - catch {unset y} + unset -nocomplain y set y(0) 1234 set info {} trace add variable y(0) write {traceUnset y} lappend info [catch {set y(0) xxx} msg] $msg } {0 {} 1 {can't read "x": no such variable} 0 {}} test trace-16.11 {unsets during write traces} { - catch {unset y} + unset -nocomplain y set y 1234 set info {} trace add variable y write {traceReset y y} lappend info [catch {set y xxx} msg] $msg } {0 {} 0 xyzzy 0 xyzzy} test trace-16.12 {unsets during write traces} { - catch {unset y} + unset -nocomplain y set y(0) 1234 set info {} trace add variable y(0) write {traceReset y(0) y(0)} lappend info [catch {set y(0) xxx} msg] $msg } {0 {} 0 xyzzy 0 xyzzy} test trace-16.13 {unsets during write traces} { - catch {unset y} + unset -nocomplain y set y(0) 1234 set info {} trace add variable y(0) write {traceReset y y(0)} lappend info [catch {set y(0) xxx} msg] $msg [catch {set y(0)} msg] $msg } {0 {} 1 {can't set "y": upvar refers to element in deleted array} 0 {} 1 {can't read "y(0)": no such variable}} test trace-16.14 {unsets during write traces} { - catch {unset y} + unset -nocomplain y set y(0) 1234 set info {} trace add variable y(0) write {traceReset2 y y(0)} lappend info [catch {set y(0) xxx} msg] $msg [catch {set y(0)} msg] $msg } {0 {} 0 xyzzy 0 {} 0 xyzzy} test trace-16.15 {unsets during unset traces} { - catch {unset y} + unset -nocomplain y set y 1234 set info {} trace add variable y unset {traceUnset y} lappend info [catch {unset y} msg] $msg [catch {set y} msg] $msg } {1 {can't unset "x": no such variable} 1 {can't read "x": no such variable} 0 {} 1 {can't read "y": no such variable}} test trace-16.16 {unsets during unset traces} { - catch {unset y} + unset -nocomplain y set y(0) 1234 set info {} trace add variable y(0) unset {traceUnset y(0)} lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg } {1 {can't unset "x": no such variable} 1 {can't read "x": no such variable} 0 {} 1 {can't read "y(0)": no such element in array}} test trace-16.17 {unsets during unset traces} { - catch {unset y} + unset -nocomplain y set y(0) 1234 set info {} trace add variable y(0) unset {traceUnset y} lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg } {0 {} 1 {can't read "x": no such variable} 0 {} 1 {can't read "y(0)": no such variable}} test trace-16.18 {unsets during unset traces} { - catch {unset y} + unset -nocomplain y set y 1234 set info {} trace add variable y unset {traceReset2 y y} lappend info [catch {unset y} msg] $msg [catch {set y} msg] $msg } {1 {can't unset "y": no such variable} 0 xyzzy 0 {} 0 xyzzy} test trace-16.19 {unsets during unset traces} { - catch {unset y} + unset -nocomplain y set y(0) 1234 set info {} trace add variable y(0) unset {traceReset2 y(0) y(0)} lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg } {1 {can't unset "y(0)": no such element in array} 0 xyzzy 0 {} 0 xyzzy} test trace-16.20 {unsets during unset traces} { - catch {unset y} + unset -nocomplain y set y(0) 1234 set info {} trace add variable y(0) unset {traceReset2 y y(0)} lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg } {0 {} 0 xyzzy 0 {} 0 xyzzy} test trace-16.21 {unsets cancelling traces} { - catch {unset y} + unset -nocomplain y set y 1234 set info {} trace add variable y read {traceAppend first} @@ -1191,7 +1189,7 @@ test trace-16.21 {unsets cancelling traces} { lappend info [catch {set y} msg] $msg } {third unset 0 {} 1 {can't read "x": no such variable} 1 {can't read "y": no such variable}} test trace-16.22 {unsets cancelling traces} { - catch {unset y} + unset -nocomplain y set y(0) 1234 set info {} trace add variable y(0) read {traceAppend first} @@ -1204,19 +1202,19 @@ test trace-16.22 {unsets cancelling traces} { # Check various non-interference between traces and other things. test trace-17.1 {trace doesn't prevent unset errors} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x unset {traceProc} list [catch {unset x} msg] $msg $info } {1 {can't unset "x": no such variable} {x {} unset}} test trace-17.2 {traced variables must survive procedure exits} { - catch {unset x} + unset -nocomplain x proc p1 {} {global x; trace add variable x write traceProc} p1 trace info variable x } {{write traceProc}} test trace-17.3 {traced variables must survive procedure exits} { - catch {unset x} + unset -nocomplain x set info {} proc p1 {} {global x; trace add variable x write traceProc} p1 @@ -1229,7 +1227,7 @@ test trace-17.3 {traced variables must survive procedure exits} { test trace-18.1 {unset traces on procedure returns} { proc p1 {x y} {set a 44; p2 14} - proc p2 {z} {trace add variable z unset {traceCheck {lsort [uplevel {info vars}]}}} + proc p2 {z} {trace add variable z unset {traceCheck {lsort [uplevel 1 {info vars}]}}} set info {} p1 foo bar set info @@ -1269,8 +1267,7 @@ test trace-18.4 {namespace delete / trace vdelete combo, Bug \#1338280} { # Delete arrays when done, so they can be re-used as scalars # elsewhere. -catch {unset x} -catch {unset y} +unset -nocomplain x y test trace-19.0.1 {trace add command (command existence)} { # Just in case! @@ -1542,8 +1539,7 @@ proc foo {b} { set a $b } # Delete arrays when done, so they can be re-used as scalars # elsewhere. -catch {unset x} -catch {unset y} +unset -nocomplain x y # Delete procedures when done, so we don't clash with other tests # (e.g. foobar will clash with 'unknown' tests). @@ -1674,6 +1670,16 @@ test trace-21.11 {trace execution and alias} -setup { rename ::x {} } -result {:: ::} +proc set2 args { + set {*}$args +} + +test trace-21.12 {bug 2438181} -setup { + trace add execution set2 leave {puts one two three #;} +} -body { + set2 a hello +} -returnCodes 1 -result {wrong # args: should be "puts ?-nonewline? ?channelId? string"} + proc factorial {n} { if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] } return 1 @@ -2050,7 +2056,7 @@ test trace-28.1 {enterstep and leavestep traces with update idletasks (615043)} trace remove execution foo {enter enterstep leavestep leave} \ [list traceExecute foo] rename foo {} - catch {unset a} + unset -nocomplain a join $info "\n" } {foo foo enter foo {set a 1} enterstep @@ -2634,9 +2640,8 @@ catch {rename traceproc {}} catch {rename runbase {}} # Unset the variable when done -catch {unset info} -catch {unset base} +unset -nocomplain info base # cleanup -::tcltest::cleanupTests +cleanupTests return diff --git a/tests/unixInit.test b/tests/unixInit.test index 9ba9c11..05338ed 100644 --- a/tests/unixInit.test +++ b/tests/unixInit.test @@ -11,7 +11,7 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. package require tcltest 2.2 -namespace import -force ::tcltest::* +namespace import ::tcltest::* unset -nocomplain path catch {set oldlang $env(LANG)} set env(LANG) C @@ -44,11 +44,11 @@ test unixInit-1.2 {initialisation: standard channel type deduction} {unix stdio} set pipe1 [open "|[list [interpreter]]" r+] puts $pipe1 { proc accept {channel host port} { - puts $channel {puts [fconfigure stdin -peername]; exit} + puts $channel {puts [chan configure stdin -peername]; exit} close $channel exit } - puts [fconfigure [socket -server accept -myaddr 127.0.0.1 0] -sockname] + puts [chan configure [socket -server accept -myaddr 127.0.0.1 0] -sockname] vwait forever \ } # Note the backslash above; this is important to make sure that the whole @@ -64,8 +64,8 @@ test unixInit-1.2 {initialisation: standard channel type deduction} {unix stdio} set pipe2 [open "|[list [interpreter] <@$sock]" r] set result [gets $pipe2] # Clear any pending data; stops certain kinds of (non-important) errors - fconfigure $pipe1 -blocking 0; gets $pipe1 - fconfigure $pipe2 -blocking 0; gets $pipe2 + chan configure $pipe1 -blocking 0; gets $pipe1 + chan configure $pipe2 -blocking 0; gets $pipe2 # Close the pipes and the socket. close $pipe2 close $pipe1 @@ -329,7 +329,7 @@ test unixInit-3.1 {TclpSetInitialEncodings} -constraints { } -body { set env(LANG) C set f [open "|[list [interpreter]]" w+] - fconfigure $f -buffering none + chan configure $f -buffering none puts $f {puts [encoding system]; exit} set enc [gets $f] close $f @@ -344,7 +344,7 @@ test unixInit-3.2 {TclpSetInitialEncodings} -setup { set env(LANG) japanese set env(LC_ALL) japanese set f [open "|[list [interpreter]]" w+] - fconfigure $f -buffering none + chan configure $f -buffering none puts $f {puts [encoding system]; exit} set enc [gets $f] close $f @@ -390,7 +390,7 @@ test unixInit-7.1 {closed standard channel: Bug 772288} -constraints { } -returnCodes 0 # cleanup -catch {unset env(LANG)} +unset -nocomplain env(LANG) catch {set env(LANG) $oldlang} unset -nocomplain path ::tcltest::cleanupTests diff --git a/tests/unknown.test b/tests/unknown.test index 40be6602..e80d3a6 100644 --- a/tests/unknown.test +++ b/tests/unknown.test @@ -11,12 +11,10 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import -force ::tcltest::* -} +package require tcltest 2 +namespace import ::tcltest::* -catch {unset x} +unset -nocomplain x catch {rename unknown unknown.old} test unknown-1.1 {non-existent "unknown" command} { @@ -59,7 +57,7 @@ test unknown-4.1 {errors in "unknown" procedure} { # cleanup catch {rename unknown {}} catch {rename unknown.old unknown} -::tcltest::cleanupTests +cleanupTests return # Local Variables: diff --git a/tests/var.test b/tests/var.test index ed7e930..5939100 100644 --- a/tests/var.test +++ b/tests/var.test @@ -793,6 +793,75 @@ test var-19.1 {crash when freeing locals hashtable: Bug 3037525} { foo ; # This crashes without the fix for the bug rename foo {} } {} + +test var-20.1 {array set compilation correctness: Bug 3603163} -setup { + unset -nocomplain x +} -body { + apply {{} { + global x + array set x {a 1} + }} + array size x +} -result 1 +test var-20.2 {array set compilation correctness: Bug 3603163} -setup { + unset -nocomplain x +} -body { + apply {{} { + global x + array set x {} + }} + array size x +} -result 0 +test var-20.3 {array set compilation correctness: Bug 3603163} -setup { + unset -nocomplain x +} -body { + apply {{} { + array set ::x {a 1} + }} + array size x +} -result 1 +test var-20.4 {array set compilation correctness: Bug 3603163} -setup { + unset -nocomplain x +} -body { + apply {{} { + array set ::x {} + }} + array size x +} -result 0 +test var-20.5 {array set compilation correctness: Bug 3603163} -setup { + unset -nocomplain x +} -body { + apply {{} { + global x + eval {array set x {a 1}} + }} + array size x +} -result 1 +test var-20.6 {array set compilation correctness: Bug 3603163} -setup { + unset -nocomplain x +} -body { + apply {{} { + global x + eval {array set x {}} + }} + array size x +} -result 0 +test var-20.7 {array set compilation correctness: Bug 3603163} -setup { + unset -nocomplain x +} -body { + apply {{} { + eval {array set ::x {a 1}} + }} + array size x +} -result 1 +test var-20.8 {array set compilation correctness: Bug 3603163} -setup { + unset -nocomplain x +} -body { + apply {{} { + eval {array set ::x {}} + }} + array size x +} -result 0 catch {namespace delete ns} catch {unset arr} diff --git a/tests/zlib.test b/tests/zlib.test index 891dba0..c469eea 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -366,6 +366,25 @@ test zlib-8.15 {transformtion and fconfigure} -setup { catch {close $inSide} catch {$strm close} } -result {358 358} +test zlib-8.16 {Bug 3603553: buffer transfer with large writes} -setup { + # Actual data isn't very important; needs to be substantially larger than + # the internal buffer (32kB) and incompressible. + set largeData {} + for {set i 0;expr srand(1)} {$i < 100000} {incr i} { + append largeData [lindex "a b c d e f g h i j k l m n o p" \ + [expr {int(16*rand())}]] + } + set file [makeFile {} test.gz] +} -constraints zlib -body { + set f [open $file wb] + fconfigure $f -buffering none + zlib push gzip $f + puts -nonewline $f $largeData + close $f + file size $file +} -cleanup { + removeFile $file +} -result 57647 test zlib-9.1 "check fcopy with push" -constraints zlib -setup { set sfile [makeFile {} testsrc.gz] diff --git a/tools/tcltk-man2html.tcl b/tools/tcltk-man2html.tcl index 4d7b989..f87f701 100755 --- a/tools/tcltk-man2html.tcl +++ b/tools/tcltk-man2html.tcl @@ -461,18 +461,15 @@ proc plus-pkgs {type args} { if {!$build_tcl} return set result {} set pkgsdir $tcltkdir/$tcldir/pkgs - foreach {dir name} $args { - set globpat $pkgsdir/{$dir,$dir\[0-9\]*}/doc/*.$type + 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 $pkgsdir/{$dir,$dir\[0-9\]*}/doc/man/*.$type + set globpat $pkgsdir/$dir/doc/man/*.$type if {![llength [glob -type f -nocomplain $globpat]]} { continue } } - regexp "pkgs/${dir}(.*)/doc$" \ - [lindex [glob -type d $pkgsdir/{$dir,$dir\[0-9\]*}/doc] 0] \ - -> version switch $type { n { set title "$name Package Commands" @@ -650,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 { @@ -674,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. # @@ -684,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/tools/tsdPerf.c b/tools/tsdPerf.c index 40004b1..e1ac552 100644 --- a/tools/tsdPerf.c +++ b/tools/tsdPerf.c @@ -33,7 +33,7 @@ tsdPerfGetObjCmd(ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *const TsdPerf *perf = Tcl_GetThreadData(&key, sizeof(TsdPerf)); - Tcl_SetObjResult(interp, Tcl_NewIntObj(perf->value)); + Tcl_SetObjResult(interp, Tcl_NewLongObj(perf->value)); return TCL_OK; } diff --git a/unix/Makefile.in b/unix/Makefile.in index 680d4ce..bdeafca 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -139,8 +139,8 @@ TCL_STUB_LIB_FLAG = @TCL_STUB_LIB_FLAG@ # To compile without backward compatibility and deprecated code uncomment the # following -NO_DEPRECATED_FLAGS = -#NO_DEPRECATED_FLAGS = -DTCL_NO_DEPRECATED +#NO_DEPRECATED_FLAGS = +NO_DEPRECATED_FLAGS = -DTCL_NO_DEPRECATED # Some versions of make, like SGI's, use the following variable to determine # which shell to use for executing commands: @@ -839,20 +839,20 @@ 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 \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/opt0.4; \ done; - @echo "Installing package msgcat 1.5.0 as a Tcl Module"; - @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/msgcat-1.5.0.tm; + @echo "Installing package msgcat 1.5.1 as a Tcl Module"; + @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/msgcat-1.5.1.tm; @echo "Installing package tcltest 2.3.5 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.3.5.tm; - @echo "Installing package platform 1.0.10 as a Tcl Module"; - @$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform-1.0.10.tm; + @echo "Installing package platform 1.0.11 as a Tcl Module"; + @$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform-1.0.11.tm; @echo "Installing package platform::shell 1.1.4 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/platform/shell.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform/shell-1.1.4.tm; @@ -866,10 +866,39 @@ install-libraries: libraries "$(SCRIPT_INSTALL_DIR)"/tm.tcl; \ fi -install-tzdata: ${NATIVE_TCLSH} +install-tzdata: + @for i in tzdata; \ + do \ + if [ ! -d "$(SCRIPT_INSTALL_DIR)"/$$i ] ; then \ + echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \ + $(INSTALL_DATA_DIR) "$(SCRIPT_INSTALL_DIR)"/$$i; \ + else true; \ + fi; \ + done; @echo "Installing time zone files to $(SCRIPT_INSTALL_DIR)/tzdata/" - @${NATIVE_TCLSH} $(TOOL_DIR)/installData.tcl \ - $(TOP_DIR)/library/tzdata "$(SCRIPT_INSTALL_DIR)"/tzdata + @for i in $(TOP_DIR)/library/tzdata/* ; do \ + if [ -d $$i ] ; then \ + ii=`basename $$i`; \ + if [ ! -d "$(SCRIPT_INSTALL_DIR)"/tzdata/$$ii ] ; then \ + $(INSTALL_DATA_DIR) "$(SCRIPT_INSTALL_DIR)"/tzdata/$$ii; \ + fi; \ + for j in $$i/* ; do \ + if [ -d $$j ] ; then \ + jj=`basename $$j`; \ + if [ ! -d "$(SCRIPT_INSTALL_DIR)"/tzdata/$$ii/$$jj ] ; then \ + $(INSTALL_DATA_DIR) "$(SCRIPT_INSTALL_DIR)"/tzdata/$$ii/$$jj; \ + fi; \ + for k in $$j/* ; do \ + $(INSTALL_DATA) $$k "$(SCRIPT_INSTALL_DIR)"/tzdata/$$ii/$$jj; \ + done; \ + else \ + $(INSTALL_DATA) $$j "$(SCRIPT_INSTALL_DIR)"/tzdata/$$ii; \ + fi; \ + done; \ + else \ + $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/tzdata; \ + fi; \ + done; install-msgs: @for i in msgs; \ @@ -1718,7 +1747,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`; \ @@ -2019,8 +2048,7 @@ dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in $(M cp -p $(TOMMATH_SRCS) $(TOMMATH_DIR)/*.h \ $(DISTDIR)/libtommath mkdir $(DISTDIR)/pkgs - cp $(TOP_DIR)/pkgs/README $(TOP_DIR)/pkgs/package.list.txt \ - $(DISTDIR)/pkgs + cp $(TOP_DIR)/pkgs/README $(DISTDIR)/pkgs for i in `ls $(DISTROOT)/pkgs/*.tar.gz 2> /dev/null`; do \ tar -C $(DISTDIR)/pkgs -xzf "$$i"; \ done diff --git a/unix/configure b/unix/configure index 82ca9df..313dcba 100755 --- a/unix/configure +++ b/unix/configure @@ -971,7 +971,7 @@ esac else echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2 fi - cd $ac_popdir + cd "$ac_popdir" done fi @@ -2017,8 +2017,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -2076,8 +2075,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -2193,8 +2191,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -2248,8 +2245,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -2294,8 +2290,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -2339,8 +2334,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -2409,8 +2403,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -2744,8 +2737,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -2915,8 +2907,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -2999,8 +2990,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -3063,8 +3053,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -3211,8 +3200,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -3359,8 +3347,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -3511,8 +3498,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -3713,8 +3699,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -3903,8 +3888,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -4051,8 +4035,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -4205,8 +4188,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -4366,8 +4348,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -4477,8 +4458,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -4553,8 +4533,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -4629,8 +4608,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -4703,8 +4681,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -4774,8 +4751,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -4889,8 +4865,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -5053,8 +5028,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -5116,8 +5090,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -5184,8 +5157,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -5244,8 +5216,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -5446,8 +5417,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -5543,8 +5513,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -5609,8 +5578,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -5712,8 +5680,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -5809,8 +5776,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -5875,8 +5841,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -6026,8 +5991,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -6168,8 +6132,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -6244,8 +6207,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -6299,8 +6261,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -6515,8 +6476,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -6586,8 +6546,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -6715,8 +6674,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -6770,7 +6728,7 @@ fi if test "$GCC" = yes; then CFLAGS_OPTIMIZE=-O2 - CFLAGS_WARNING="-Wall" + CFLAGS_WARNING="-Wall -Wwrite-strings" else @@ -7009,8 +6967,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -7103,8 +7060,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -7199,8 +7155,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -7292,8 +7247,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -7426,8 +7380,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -7635,8 +7588,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -7986,8 +7938,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -8052,8 +8003,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -8135,8 +8085,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -8210,8 +8159,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -8319,8 +8267,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -8400,8 +8347,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -8795,8 +8741,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -9011,8 +8956,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -9246,8 +9190,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -9437,8 +9380,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -9480,8 +9422,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -9542,8 +9483,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -9585,8 +9525,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -9647,8 +9586,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -9690,8 +9628,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -9766,8 +9703,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -9816,8 +9752,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -9887,8 +9822,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -9950,8 +9884,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -10052,8 +9985,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -10116,8 +10048,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -10196,8 +10127,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -10239,8 +10169,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -10297,8 +10226,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -10467,8 +10395,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -10581,8 +10508,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -10689,8 +10615,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -10789,8 +10714,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -10889,8 +10813,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -10989,8 +10912,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -11096,8 +11018,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -11206,8 +11127,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -11279,8 +11199,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -11351,8 +11270,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -11423,8 +11341,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -11495,8 +11412,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -11609,8 +11525,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -11708,8 +11623,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -11775,8 +11689,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -11847,8 +11760,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -11955,8 +11867,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -12022,8 +11933,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -12094,8 +12004,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -12202,8 +12111,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -12269,8 +12177,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -12341,8 +12248,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -12449,8 +12355,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -12516,8 +12421,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -12588,8 +12492,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -12729,8 +12632,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -12796,8 +12698,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -12868,8 +12769,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -12938,8 +12838,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -13047,8 +12946,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -13117,8 +13015,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -13192,8 +13089,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -13239,14 +13135,16 @@ fi fi #--------------------------------------------------------------------------- -# Determine which interface to use to talk to the serial port. -# Note that #include lines must begin in leftmost column for -# some compilers to recognize them as preprocessor directives. +# Check for serial port interface. +# +# termios.h is present on all POSIX systems. +# sys/ioctl.h is almost always present, though what it contains +# is system-specific. +# sys/modem.h is needed on HP-UX. #--------------------------------------------------------------------------- - -for ac_header in sys/modem.h +for ac_header in termios.h do as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh` if eval "test \"\${$as_ac_Header+set}\" = set"; then @@ -13279,8 +13177,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -13395,310 +13292,303 @@ fi done - echo "$as_me:$LINENO: checking termios vs. termio vs. sgtty" >&5 -echo $ECHO_N "checking termios vs. termio vs. sgtty... $ECHO_C" >&6 -if test "${tcl_cv_api_serial+set}" = set; then - echo $ECHO_N "(cached) $ECHO_C" >&6 -else - if test "$cross_compiling" = yes; then - tcl_cv_api_serial=no +for ac_header in sys/ioctl.h +do +as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh` +if eval "test \"\${$as_ac_Header+set}\" = set"; then + echo "$as_me:$LINENO: checking for $ac_header" >&5 +echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6 +if eval "test \"\${$as_ac_Header+set}\" = set"; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +fi +echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 +echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 else - cat >conftest.$ac_ext <<_ACEOF + # Is the header compilable? +echo "$as_me:$LINENO: checking $ac_header usability" >&5 +echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6 +cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ - -#include <termios.h> - -int main() { - struct termios t; - if (tcgetattr(0, &t) == 0) { - cfsetospeed(&t, 0); - t.c_cflag |= PARENB | PARODD | CSIZE | CSTOPB; - return 0; - } - return 1; -} +$ac_includes_default +#include <$ac_header> _ACEOF -rm -f conftest$ac_exeext -if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>&5 +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { ac_try='./conftest$ac_exeext' + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; }; then - tcl_cv_api_serial=termios -else - echo "$as_me: program exited with status $ac_status" >&5 -echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -( exit $ac_status ) -tcl_cv_api_serial=no -fi -rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext -fi - if test $tcl_cv_api_serial = no ; then - if test "$cross_compiling" = yes; then - tcl_cv_api_serial=no -else - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ - -#include <termio.h> - -int main() { - struct termio t; - if (ioctl(0, TCGETA, &t) == 0) { - t.c_cflag |= CBAUD | PARENB | PARODD | CSIZE | CSTOPB; - return 0; - } - return 1; -} -_ACEOF -rm -f conftest$ac_exeext -if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { ac_try='./conftest$ac_exeext' + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then - tcl_cv_api_serial=termio + ac_header_compiler=yes else - echo "$as_me: program exited with status $ac_status" >&5 -echo "$as_me: failed program was:" >&5 + echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 -( exit $ac_status ) -tcl_cv_api_serial=no -fi -rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext +ac_header_compiler=no fi - fi - if test $tcl_cv_api_serial = no ; then - if test "$cross_compiling" = yes; then - tcl_cv_api_serial=no -else - cat >conftest.$ac_ext <<_ACEOF +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 +echo "${ECHO_T}$ac_header_compiler" >&6 + +# Is the header present? +echo "$as_me:$LINENO: checking $ac_header presence" >&5 +echo $ECHO_N "checking $ac_header presence... $ECHO_C" >&6 +cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ - -#include <sgtty.h> - -int main() { - struct sgttyb t; - if (ioctl(0, TIOCGETP, &t) == 0) { - t.sg_ospeed = 0; - t.sg_flags |= ODDP | EVENP | RAW; - return 0; - } - return 1; -} +#include <$ac_header> _ACEOF -rm -f conftest$ac_exeext -if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { ac_try='./conftest$ac_exeext' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 +if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 + (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; }; then - tcl_cv_api_serial=sgtty + (exit $ac_status); } >/dev/null; then + if test -s conftest.err; then + ac_cpp_err=$ac_c_preproc_warn_flag + ac_cpp_err=$ac_cpp_err$ac_c_werror_flag + else + ac_cpp_err= + fi else - echo "$as_me: program exited with status $ac_status" >&5 -echo "$as_me: failed program was:" >&5 + ac_cpp_err=yes +fi +if test -z "$ac_cpp_err"; then + ac_header_preproc=yes +else + echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 -( exit $ac_status ) -tcl_cv_api_serial=no -fi -rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext + ac_header_preproc=no fi - fi - if test $tcl_cv_api_serial = no ; then - if test "$cross_compiling" = yes; then - tcl_cv_api_serial=no -else - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ +rm -f conftest.err conftest.$ac_ext +echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 +echo "${ECHO_T}$ac_header_preproc" >&6 -#include <termios.h> -#include <errno.h> +# So? What about this header? +case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in + yes:no: ) + { echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5 +echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5 +echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;} + ac_header_preproc=yes + ;; + no:yes:* ) + { echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5 +echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5 +echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5 +echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5 +echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5 +echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5 +echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;} + ( + cat <<\_ASBOX +## ------------------------------ ## +## Report this to the tcl lists. ## +## ------------------------------ ## +_ASBOX + ) | + sed "s/^/$as_me: WARNING: /" >&2 + ;; +esac +echo "$as_me:$LINENO: checking for $ac_header" >&5 +echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6 +if eval "test \"\${$as_ac_Header+set}\" = set"; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + eval "$as_ac_Header=\$ac_header_preproc" +fi +echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 +echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 -int main() { - struct termios t; - if (tcgetattr(0, &t) == 0 - || errno == ENOTTY || errno == ENXIO || errno == EINVAL) { - cfsetospeed(&t, 0); - t.c_cflag |= PARENB | PARODD | CSIZE | CSTOPB; - return 0; - } - return 1; -} +fi +if test `eval echo '${'$as_ac_Header'}'` = yes; then + cat >>confdefs.h <<_ACEOF +#define `echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF -rm -f conftest$ac_exeext -if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { ac_try='./conftest$ac_exeext' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; }; then - tcl_cv_api_serial=termios -else - echo "$as_me: program exited with status $ac_status" >&5 -echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 -( exit $ac_status ) -tcl_cv_api_serial=no fi -rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext + +done + + +for ac_header in sys/modem.h +do +as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh` +if eval "test \"\${$as_ac_Header+set}\" = set"; then + echo "$as_me:$LINENO: checking for $ac_header" >&5 +echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6 +if eval "test \"\${$as_ac_Header+set}\" = set"; then + echo $ECHO_N "(cached) $ECHO_C" >&6 fi - fi - if test $tcl_cv_api_serial = no; then - if test "$cross_compiling" = yes; then - tcl_cv_api_serial=no +echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 +echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 else - cat >conftest.$ac_ext <<_ACEOF + # Is the header compilable? +echo "$as_me:$LINENO: checking $ac_header usability" >&5 +echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6 +cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ - -#include <termio.h> -#include <errno.h> - -int main() { - struct termio t; - if (ioctl(0, TCGETA, &t) == 0 - || errno == ENOTTY || errno == ENXIO || errno == EINVAL) { - t.c_cflag |= CBAUD | PARENB | PARODD | CSIZE | CSTOPB; - return 0; - } - return 1; - } +$ac_includes_default +#include <$ac_header> _ACEOF -rm -f conftest$ac_exeext -if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>&5 +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { ac_try='./conftest$ac_exeext' + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); }; }; then - tcl_cv_api_serial=termio + ac_header_compiler=yes else - echo "$as_me: program exited with status $ac_status" >&5 -echo "$as_me: failed program was:" >&5 + echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 -( exit $ac_status ) -tcl_cv_api_serial=no -fi -rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext +ac_header_compiler=no fi - fi - if test $tcl_cv_api_serial = no; then - if test "$cross_compiling" = yes; then - tcl_cv_api_serial=none -else - cat >conftest.$ac_ext <<_ACEOF +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 +echo "${ECHO_T}$ac_header_compiler" >&6 + +# Is the header present? +echo "$as_me:$LINENO: checking $ac_header presence" >&5 +echo $ECHO_N "checking $ac_header presence... $ECHO_C" >&6 +cat >conftest.$ac_ext <<_ACEOF /* confdefs.h. */ _ACEOF cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ - -#include <sgtty.h> -#include <errno.h> - -int main() { - struct sgttyb t; - if (ioctl(0, TIOCGETP, &t) == 0 - || errno == ENOTTY || errno == ENXIO || errno == EINVAL) { - t.sg_ospeed = 0; - t.sg_flags |= ODDP | EVENP | RAW; - return 0; - } - return 1; -} +#include <$ac_header> _ACEOF -rm -f conftest$ac_exeext -if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { ac_try='./conftest$ac_exeext' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 +if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 + (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; }; then - tcl_cv_api_serial=sgtty + (exit $ac_status); } >/dev/null; then + if test -s conftest.err; then + ac_cpp_err=$ac_c_preproc_warn_flag + ac_cpp_err=$ac_cpp_err$ac_c_werror_flag + else + ac_cpp_err= + fi else - echo "$as_me: program exited with status $ac_status" >&5 -echo "$as_me: failed program was:" >&5 + ac_cpp_err=yes +fi +if test -z "$ac_cpp_err"; then + ac_header_preproc=yes +else + echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 -( exit $ac_status ) -tcl_cv_api_serial=none + ac_header_preproc=no fi -rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext +rm -f conftest.err conftest.$ac_ext +echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 +echo "${ECHO_T}$ac_header_preproc" >&6 + +# So? What about this header? +case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in + yes:no: ) + { echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5 +echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5 +echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;} + ac_header_preproc=yes + ;; + no:yes:* ) + { echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5 +echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5 +echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5 +echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5 +echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5 +echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5 +echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;} + ( + cat <<\_ASBOX +## ------------------------------ ## +## Report this to the tcl lists. ## +## ------------------------------ ## +_ASBOX + ) | + sed "s/^/$as_me: WARNING: /" >&2 + ;; +esac +echo "$as_me:$LINENO: checking for $ac_header" >&5 +echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6 +if eval "test \"\${$as_ac_Header+set}\" = set"; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + eval "$as_ac_Header=\$ac_header_preproc" fi - fi +echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 +echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 + fi -echo "$as_me:$LINENO: result: $tcl_cv_api_serial" >&5 -echo "${ECHO_T}$tcl_cv_api_serial" >&6 - case $tcl_cv_api_serial in - termios) -cat >>confdefs.h <<\_ACEOF -#define USE_TERMIOS 1 -_ACEOF -;; - termio) -cat >>confdefs.h <<\_ACEOF -#define USE_TERMIO 1 -_ACEOF -;; - sgtty) -cat >>confdefs.h <<\_ACEOF -#define USE_SGTTY 1 +if test `eval echo '${'$as_ac_Header'}'` = yes; then + cat >>confdefs.h <<_ACEOF +#define `echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF -;; - esac + +fi + +done #-------------------------------------------------------------------- @@ -13741,8 +13631,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -13849,8 +13738,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -13998,8 +13886,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -14102,8 +13989,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -14166,8 +14052,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -14228,8 +14113,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -14296,8 +14180,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -14362,8 +14245,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -14438,8 +14320,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -14482,8 +14363,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -14547,8 +14427,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -14591,8 +14470,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -14659,8 +14537,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -14757,8 +14634,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -14951,8 +14827,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -15064,8 +14939,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -15231,8 +15105,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -15398,8 +15271,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -15567,8 +15439,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -15716,8 +15587,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -15782,8 +15652,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -15848,8 +15717,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -15956,8 +15824,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -16020,8 +15887,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -16087,8 +15953,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -16155,8 +16020,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -16223,8 +16087,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -16332,8 +16195,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -16411,8 +16273,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -16515,8 +16376,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -16585,8 +16445,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -16657,8 +16516,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -16776,8 +16634,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -16885,8 +16742,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -16949,8 +16805,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -17098,8 +16953,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -17244,8 +17098,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -17356,8 +17209,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -17426,8 +17278,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -17533,8 +17384,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -17600,8 +17450,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -17785,8 +17634,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -17853,8 +17701,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -18038,8 +17885,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -18140,8 +17986,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -18228,8 +18073,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -18385,8 +18229,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -18459,8 +18302,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -18542,8 +18384,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -18616,8 +18457,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -18766,8 +18606,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -19072,8 +18911,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -19300,8 +19138,7 @@ if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 cat conftest.err >&5 echo "$as_me:$LINENO: \$? = $ac_status" >&5 (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' + { ac_try='test -z "$ac_c_werror_flag" || test ! -s conftest.err' { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 (eval $ac_try) 2>&5 ac_status=$? @@ -20472,11 +20309,6 @@ esac - if test x"$ac_file" != x-; then - { echo "$as_me:$LINENO: creating $ac_file" >&5 -echo "$as_me: creating $ac_file" >&6;} - rm -f "$ac_file" - fi # Let's still pretend it is `configure' which instantiates (i.e., don't # use $as_me), people would be surprised to read: # /* config.h. Generated by config.status. */ @@ -20515,6 +20347,12 @@ echo "$as_me: error: cannot find input file: $f" >&2;} fi;; esac done` || { (exit 1); exit 1; } + + if test x"$ac_file" != x-; then + { echo "$as_me:$LINENO: creating $ac_file" >&5 +echo "$as_me: creating $ac_file" >&6;} + rm -f "$ac_file" + fi _ACEOF cat >>$CONFIG_STATUS <<_ACEOF sed "$ac_vpsub diff --git a/unix/configure.in b/unix/configure.in index 4ebf1af..9993ec6 100644 --- a/unix/configure.in +++ b/unix/configure.in @@ -259,12 +259,17 @@ if test "${TCL_THREADS}" = 1; then fi #--------------------------------------------------------------------------- -# Determine which interface to use to talk to the serial port. -# Note that #include lines must begin in leftmost column for -# some compilers to recognize them as preprocessor directives. +# Check for serial port interface. +# +# termios.h is present on all POSIX systems. +# sys/ioctl.h is almost always present, though what it contains +# is system-specific. +# sys/modem.h is needed on HP-UX. #--------------------------------------------------------------------------- -SC_SERIAL_PORT +AC_CHECK_HEADERS(termios.h) +AC_CHECK_HEADERS(sys/ioctl.h) +AC_CHECK_HEADERS(sys/modem.h) #-------------------------------------------------------------------- # Include sys/select.h if it exists and if it supplies things diff --git a/unix/dltest/pkga.c b/unix/dltest/pkga.c index 7e5d7d3..d21ef95 100644 --- a/unix/dltest/pkga.c +++ b/unix/dltest/pkga.c @@ -62,7 +62,7 @@ Pkga_EqObjCmd( } else { result = 0; } - Tcl_SetObjResult(interp, Tcl_NewIntObj(result)); + Tcl_SetObjResult(interp, Tcl_NewLongObj(result)); return TCL_OK; } @@ -122,10 +122,10 @@ Pkga_Init( { int code; - if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) { + if (Tcl_InitStubs(interp, "9.0", 0) == NULL) { return TCL_ERROR; } - code = Tcl_PkgProvide(interp, "Pkga", "1.0"); + code = Tcl_PkgProvideEx(interp, "Pkga", "1.0", NULL); if (code != TCL_OK) { return code; } diff --git a/unix/dltest/pkgb.c b/unix/dltest/pkgb.c index e003ed6..591e225 100644 --- a/unix/dltest/pkgb.c +++ b/unix/dltest/pkgb.c @@ -41,6 +41,10 @@ static int Pkgb_DemoObjCmd(ClientData clientData, *---------------------------------------------------------------------- */ +#ifndef Tcl_GetErrorLine +# define Tcl_GetErrorLine(interp) ((interp)->errorLine) +#endif + static int Pkgb_SubObjCmd( ClientData dummy, /* Not used. */ @@ -56,9 +60,12 @@ 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)); + Tcl_SetObjResult(interp, Tcl_NewLongObj(first - second)); return TCL_OK; } @@ -89,22 +96,6 @@ Pkgb_UnsafeObjCmd( return Tcl_EvalEx(interp, "list unsafe command invoked", -1, TCL_EVAL_GLOBAL); } -#if (TCL_MAJOR_VERSION > 8) -const char *Tcl_GetDefaultEncodingDir(void) -{ - int numDirs; - Tcl_Obj *first, *searchPath = Tcl_GetEncodingSearchPath(); - - Tcl_ListObjLength(NULL, searchPath, &numDirs); - if (numDirs == 0) { - return NULL; - } - Tcl_ListObjIndex(NULL, searchPath, 0, &first); - - return Tcl_GetString(first); -} -#endif - static int Pkgb_DemoObjCmd( ClientData dummy, /* Not used. */ @@ -112,7 +103,16 @@ Pkgb_DemoObjCmd( 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; } @@ -140,7 +140,7 @@ Pkgb_Init( { int code; - if (Tcl_InitStubs(interp, "8.5-9.1", 0) == NULL) { + if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) { return TCL_ERROR; } code = Tcl_PkgProvideEx(interp, "Pkgb", "2.3", NULL); @@ -177,7 +177,7 @@ Pkgb_SafeInit( { int code; - if (Tcl_InitStubs(interp, "8.5-9.1", 0) == NULL) { + if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) { return TCL_ERROR; } code = Tcl_PkgProvideEx(interp, "Pkgb", "2.3", NULL); diff --git a/unix/dltest/pkgc.c b/unix/dltest/pkgc.c index 4e3e174..a1d9ba0 100644 --- a/unix/dltest/pkgc.c +++ b/unix/dltest/pkgc.c @@ -56,7 +56,7 @@ Pkgc_SubObjCmd( || (Tcl_GetIntFromObj(interp, objv[2], &second) != TCL_OK)) { return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_NewIntObj(first - second)); + Tcl_SetObjResult(interp, Tcl_NewLongObj(first - second)); return TCL_OK; } @@ -112,10 +112,10 @@ Pkgc_Init( { int code; - if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) { + if (Tcl_InitStubs(interp, "9.0", 0) == NULL) { return TCL_ERROR; } - code = Tcl_PkgProvide(interp, "Pkgc", "1.7.2"); + code = Tcl_PkgProvideEx(interp, "Pkgc", "1.7.2", NULL); if (code != TCL_OK) { return code; } @@ -149,10 +149,10 @@ Pkgc_SafeInit( { int code; - if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) { + if (Tcl_InitStubs(interp, "9.0", 0) == NULL) { return TCL_ERROR; } - code = Tcl_PkgProvide(interp, "Pkgc", "1.7.2"); + code = Tcl_PkgProvideEx(interp, "Pkgc", "1.7.2", NULL); if (code != TCL_OK) { return code; } diff --git a/unix/dltest/pkgd.c b/unix/dltest/pkgd.c index 4a1defa..3718dfb 100644 --- a/unix/dltest/pkgd.c +++ b/unix/dltest/pkgd.c @@ -56,7 +56,7 @@ Pkgd_SubObjCmd( || (Tcl_GetIntFromObj(interp, objv[2], &second) != TCL_OK)) { return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_NewIntObj(first - second)); + Tcl_SetObjResult(interp, Tcl_NewLongObj(first - second)); return TCL_OK; } @@ -112,10 +112,10 @@ Pkgd_Init( { int code; - if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) { + if (Tcl_InitStubs(interp, "9.0", 0) == NULL) { return TCL_ERROR; } - code = Tcl_PkgProvide(interp, "Pkgd", "7.3"); + code = Tcl_PkgProvideEx(interp, "Pkgd", "7.3", NULL); if (code != TCL_OK) { return code; } @@ -149,10 +149,10 @@ Pkgd_SafeInit( { int code; - if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) { + if (Tcl_InitStubs(interp, "9.0", 0) == NULL) { return TCL_ERROR; } - code = Tcl_PkgProvide(interp, "Pkgd", "7.3"); + code = Tcl_PkgProvideEx(interp, "Pkgd", "7.3", NULL); if (code != TCL_OK) { return code; } diff --git a/unix/dltest/pkge.c b/unix/dltest/pkge.c index 36c8c1a..c3380a7 100644 --- a/unix/dltest/pkge.c +++ b/unix/dltest/pkge.c @@ -38,8 +38,8 @@ Pkge_Init( { static const char script[] = "if 44 {open non_existent}"; - if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) { + if (Tcl_InitStubs(interp, "9.0", 0) == NULL) { return TCL_ERROR; } - return Tcl_Eval(interp, script); + return Tcl_EvalEx(interp, script, -1, 0); } diff --git a/unix/dltest/pkgua.c b/unix/dltest/pkgua.c index 2a38525..a320bce 100644 --- a/unix/dltest/pkgua.c +++ b/unix/dltest/pkgua.c @@ -138,7 +138,7 @@ PkguaEqObjCmd( } else { result = 0; } - Tcl_SetObjResult(interp, Tcl_NewIntObj(result)); + Tcl_SetObjResult(interp, Tcl_NewLongObj(result)); return TCL_OK; } @@ -199,7 +199,7 @@ Pkgua_Init( int code, cmdIndex = 0; Tcl_Command *cmdTokens; - if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) { + if (Tcl_InitStubs(interp, "9.0", 0) == NULL) { return TCL_ERROR; } @@ -210,7 +210,7 @@ Pkgua_Init( PkguaInitTokensHashTable(); - code = Tcl_PkgProvide(interp, "Pkgua", "1.0"); + code = Tcl_PkgProvideEx(interp, "Pkgua", "1.0", NULL); if (code != TCL_OK) { return code; } diff --git a/unix/tcl.m4 b/unix/tcl.m4 index b13fddd..3c54c24 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -1110,7 +1110,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ CFLAGS_DEBUG=-g AS_IF([test "$GCC" = yes], [ CFLAGS_OPTIMIZE=-O2 - CFLAGS_WARNING="-Wall" + CFLAGS_WARNING="-Wall -Wwrite-strings" ], [ CFLAGS_OPTIMIZE=-O CFLAGS_WARNING="" @@ -2191,124 +2191,6 @@ dnl # preprocessing tests use only CPPFLAGS. ]) #-------------------------------------------------------------------- -# SC_SERIAL_PORT -# -# Determine which interface to use to talk to the serial port. -# Note that #include lines must begin in leftmost column for -# some compilers to recognize them as preprocessor directives, -# and some build environments have stdin not pointing at a -# pseudo-terminal (usually /dev/null instead.) -# -# Arguments: -# none -# -# Results: -# -# Defines only one of the following vars: -# HAVE_SYS_MODEM_H -# USE_TERMIOS -# USE_TERMIO -# USE_SGTTY -# -#-------------------------------------------------------------------- - -AC_DEFUN([SC_SERIAL_PORT], [ - AC_CHECK_HEADERS(sys/modem.h) - AC_CACHE_CHECK([termios vs. termio vs. sgtty], tcl_cv_api_serial, [ - AC_TRY_RUN([ -#include <termios.h> - -int main() { - struct termios t; - if (tcgetattr(0, &t) == 0) { - cfsetospeed(&t, 0); - t.c_cflag |= PARENB | PARODD | CSIZE | CSTOPB; - return 0; - } - return 1; -}], tcl_cv_api_serial=termios, tcl_cv_api_serial=no, tcl_cv_api_serial=no) - if test $tcl_cv_api_serial = no ; then - AC_TRY_RUN([ -#include <termio.h> - -int main() { - struct termio t; - if (ioctl(0, TCGETA, &t) == 0) { - t.c_cflag |= CBAUD | PARENB | PARODD | CSIZE | CSTOPB; - return 0; - } - return 1; -}], tcl_cv_api_serial=termio, tcl_cv_api_serial=no, tcl_cv_api_serial=no) - fi - if test $tcl_cv_api_serial = no ; then - AC_TRY_RUN([ -#include <sgtty.h> - -int main() { - struct sgttyb t; - if (ioctl(0, TIOCGETP, &t) == 0) { - t.sg_ospeed = 0; - t.sg_flags |= ODDP | EVENP | RAW; - return 0; - } - return 1; -}], tcl_cv_api_serial=sgtty, tcl_cv_api_serial=no, tcl_cv_api_serial=no) - fi - if test $tcl_cv_api_serial = no ; then - AC_TRY_RUN([ -#include <termios.h> -#include <errno.h> - -int main() { - struct termios t; - if (tcgetattr(0, &t) == 0 - || errno == ENOTTY || errno == ENXIO || errno == EINVAL) { - cfsetospeed(&t, 0); - t.c_cflag |= PARENB | PARODD | CSIZE | CSTOPB; - return 0; - } - return 1; -}], tcl_cv_api_serial=termios, tcl_cv_api_serial=no, tcl_cv_api_serial=no) - fi - if test $tcl_cv_api_serial = no; then - AC_TRY_RUN([ -#include <termio.h> -#include <errno.h> - -int main() { - struct termio t; - if (ioctl(0, TCGETA, &t) == 0 - || errno == ENOTTY || errno == ENXIO || errno == EINVAL) { - t.c_cflag |= CBAUD | PARENB | PARODD | CSIZE | CSTOPB; - return 0; - } - return 1; - }], tcl_cv_api_serial=termio, tcl_cv_api_serial=no, tcl_cv_api_serial=no) - fi - if test $tcl_cv_api_serial = no; then - AC_TRY_RUN([ -#include <sgtty.h> -#include <errno.h> - -int main() { - struct sgttyb t; - if (ioctl(0, TIOCGETP, &t) == 0 - || errno == ENOTTY || errno == ENXIO || errno == EINVAL) { - t.sg_ospeed = 0; - t.sg_flags |= ODDP | EVENP | RAW; - return 0; - } - return 1; -}], tcl_cv_api_serial=sgtty, tcl_cv_api_serial=none, tcl_cv_api_serial=none) - fi]) - case $tcl_cv_api_serial in - termios) AC_DEFINE(USE_TERMIOS, 1, [Use the termios API for serial lines]);; - termio) AC_DEFINE(USE_TERMIO, 1, [Use the termio API for serial lines]);; - sgtty) AC_DEFINE(USE_SGTTY, 1, [Use the sgtty API for serial lines]);; - esac -]) - -#-------------------------------------------------------------------- # SC_MISSING_POSIX_HEADERS # # Supply substitutes for missing POSIX header files. Special diff --git a/unix/tclAppInit.c b/unix/tclAppInit.c index 21dce71..f3edcff 100644 --- a/unix/tclAppInit.c +++ b/unix/tclAppInit.c @@ -48,7 +48,7 @@ MODULE_SCOPE int main(int, char **); */ #ifdef TCL_LOCAL_MAIN_HOOK -extern int TCL_LOCAL_MAIN_HOOK(int *argc, char ***argv); +MODULE_SCOPE int TCL_LOCAL_MAIN_HOOK(int *argc, char ***argv); #endif /* @@ -150,9 +150,11 @@ Tcl_AppInit( */ #ifdef DJGPP - (Tcl_SetVar2)(interp, "tcl_rcFileName", NULL, "~/tclsh.rc", TCL_GLOBAL_ONLY); + (Tcl_ObjSetVar2)(interp, Tcl_NewStringObj("tcl_rcFileName", -1), NULL, + Tcl_NewStringObj("~/tclsh.rc", -1), TCL_GLOBAL_ONLY); #else - (Tcl_SetVar2)(interp, "tcl_rcFileName", NULL, "~/.tclshrc", TCL_GLOBAL_ONLY); + (Tcl_ObjSetVar2)(interp, Tcl_NewStringObj("tcl_rcFileName", -1), NULL, + Tcl_NewStringObj("~/.tclshrc", -1), TCL_GLOBAL_ONLY); #endif return TCL_OK; diff --git a/unix/tclConfig.h.in b/unix/tclConfig.h.in index f171cce..8069b68 100644 --- a/unix/tclConfig.h.in +++ b/unix/tclConfig.h.in @@ -433,15 +433,6 @@ /* Should we use FIONBIO? */ #undef USE_FIONBIO -/* Use the sgtty API for serial lines */ -#undef USE_SGTTY - -/* Use the termio API for serial lines */ -#undef USE_TERMIO - -/* Use the termios API for serial lines */ -#undef USE_TERMIOS - /* Do we want to use the threaded memory allocator? */ #undef USE_THREAD_ALLOC diff --git a/unix/tclUnixChan.c b/unix/tclUnixChan.c index 9ee37f1..9b4d690 100644 --- a/unix/tclUnixChan.c +++ b/unix/tclUnixChan.c @@ -14,16 +14,9 @@ #include "tclInt.h" /* Internal definitions for Tcl. */ #include "tclIO.h" /* To get Channel type declaration. */ -#define SUPPORTS_TTY - -#undef DIRECT_BAUD -#ifdef B4800 -# if (B4800 == 4800) -# define DIRECT_BAUD -# endif /* B4800 == 4800 */ -#endif /* B4800 */ - -#ifdef USE_TERMIOS +#undef SUPPORTS_TTY +#if defined(HAVE_TERMIOS_H) +# define SUPPORTS_TTY 1 # include <termios.h> # ifdef HAVE_SYS_IOCTL_H # include <sys/ioctl.h> @@ -31,60 +24,29 @@ # ifdef HAVE_SYS_MODEM_H # include <sys/modem.h> # endif /* HAVE_SYS_MODEM_H */ -# define IOSTATE struct termios -# define GETIOSTATE(fd, statePtr) tcgetattr((fd), (statePtr)) -# define SETIOSTATE(fd, statePtr) tcsetattr((fd), TCSADRAIN, (statePtr)) -# define GETCONTROL(fd, intPtr) ioctl((fd), TIOCMGET, (intPtr)) -# define SETCONTROL(fd, intPtr) ioctl((fd), TIOCMSET, (intPtr)) # ifdef FIONREAD # define GETREADQUEUE(fd, int) ioctl((fd), FIONREAD, &(int)) # elif defined(FIORDCHK) # define GETREADQUEUE(fd, int) int = ioctl((fd), FIORDCHK, NULL) -# endif /* FIONREAD */ +# else +# define GETREADQUEUE(fd, int) int = 0 +# endif + # ifdef TIOCOUTQ # define GETWRITEQUEUE(fd, int) ioctl((fd), TIOCOUTQ, &(int)) -# endif /* TIOCOUTQ */ -# if defined(TIOCSBRK) && defined(TIOCCBRK) - -/* - * Can't use ?: operator below because that messes up types on either Linux or - * Solaris (the two are mutually exclusive!) - */ +# else +# define GETWRITEQUEUE(fd, int) int = 0 +# endif -# define SETBREAK(fd, flag) \ - if (flag) { \ - ioctl((fd), TIOCSBRK, NULL); \ - } else { \ - ioctl((fd), TIOCCBRK, NULL); \ - } -# endif /* TIOCSBRK&TIOCCBRK */ # if !defined(CRTSCTS) && defined(CNEW_RTSCTS) # define CRTSCTS CNEW_RTSCTS # endif /* !CRTSCTS&CNEW_RTSCTS */ # if !defined(PAREXT) && defined(CMSPAR) # define PAREXT CMSPAR # endif /* !PAREXT&&CMSPAR */ -#else /* !USE_TERMIOS */ - -#ifdef USE_TERMIO -# include <termio.h> -# define IOSTATE struct termio -# define GETIOSTATE(fd, statePtr) ioctl((fd), TCGETA, (statePtr)) -# define SETIOSTATE(fd, statePtr) ioctl((fd), TCSETAW, (statePtr)) -#else /* !USE_TERMIO */ - -#ifdef USE_SGTTY -# include <sgtty.h> -# define IOSTATE struct sgttyb -# define GETIOSTATE(fd, statePtr) ioctl((fd), TIOCGETP, (statePtr)) -# define SETIOSTATE(fd, statePtr) ioctl((fd), TIOCSETP, (statePtr)) -#else /* !USE_SGTTY */ -# undef SUPPORTS_TTY -#endif /* !USE_SGTTY */ - -#endif /* !USE_TERMIO */ -#endif /* !USE_TERMIOS */ + +#endif /* HAVE_TERMIOS_H */ /* * Helper macros to make parts of this file clearer. The macros do exactly @@ -99,7 +61,7 @@ * This structure describes per-instance state of a file based channel. */ -typedef struct FileState { +typedef struct { Tcl_Channel channel; /* Channel associated with this file. */ int fd; /* File handle. */ int validMask; /* OR'ed combination of TCL_READABLE, @@ -110,23 +72,11 @@ typedef struct FileState { #ifdef SUPPORTS_TTY /* - * The following structure describes per-instance state of a tty-based - * channel. - */ - -typedef struct TtyState { - FileState fs; /* Per-instance state of the file descriptor. - * Must be the first field. */ - IOSTATE savedState; /* Initial state of device. Used to reset - * state when device closed. */ -} TtyState; - -/* * The following structure is used to set or get the serial port attributes in * a platform-independant manner. */ -typedef struct TtyAttrs { +typedef struct { int baud; int parity; int data; @@ -167,15 +117,12 @@ static void TtyGetAttributes(int fd, TtyAttrs *ttyPtr); static int TtyGetOptionProc(ClientData instanceData, Tcl_Interp *interp, const char *optionName, Tcl_DString *dsPtr); -#ifndef DIRECT_BAUD -static int TtyGetBaud(unsigned long speed); -static unsigned long TtyGetSpeed(int baud); -#endif /* DIRECT_BAUD */ -static FileState * TtyInit(int fd, int initialize); +static int TtyGetBaud(speed_t speed); +static speed_t TtyGetSpeed(int baud); +static void TtyInit(int fd); static void TtyModemStatusStr(int status, Tcl_DString *dsPtr); static int TtyParseMode(Tcl_Interp *interp, const char *mode, - int *speedPtr, int *parityPtr, int *dataPtr, - int *stopPtr); + TtyAttrs *ttyPtr); static void TtySetAttributes(int fd, TtyAttrs *ttyPtr); static int TtySetOptionProc(ClientData instanceData, Tcl_Interp *interp, const char *optionName, @@ -573,7 +520,6 @@ FileGetHandleProc( } #ifdef SUPPORTS_TTY -#ifdef USE_TERMIOS /* *---------------------------------------------------------------------- * @@ -606,7 +552,6 @@ TtyModemStatusStr( Tcl_DStringAppendElement(dsPtr, (status & TIOCM_CD) ? "1" : "0"); #endif /* TIOCM_CD */ } -#endif /* USE_TERMIOS */ /* *---------------------------------------------------------------------- @@ -636,11 +581,9 @@ TtySetOptionProc( FileState *fsPtr = instanceData; unsigned int len, vlen; TtyAttrs tty; -#ifdef USE_TERMIOS - int flag, control, argc; + int argc; const char **argv; - IOSTATE iostate; -#endif /* USE_TERMIOS */ + struct termios iostate; len = strlen(optionName); vlen = strlen(value); @@ -650,8 +593,7 @@ TtySetOptionProc( */ if ((len > 2) && (strncmp(optionName, "-mode", len) == 0)) { - if (TtyParseMode(interp, value, &tty.baud, &tty.parity, &tty.data, - &tty.stop) != TCL_OK) { + if (TtyParseMode(interp, value, &tty) != TCL_OK) { return TCL_ERROR; } @@ -663,7 +605,6 @@ TtySetOptionProc( return TCL_OK; } -#ifdef USE_TERMIOS /* * Option -handshake none|xonxoff|rtscts|dtrdsr @@ -674,25 +615,25 @@ TtySetOptionProc( * Reset all handshake options. DTR and RTS are ON by default. */ - GETIOSTATE(fsPtr->fd, &iostate); + tcgetattr(fsPtr->fd, &iostate); CLEAR_BITS(iostate.c_iflag, IXON | IXOFF | IXANY); #ifdef CRTSCTS CLEAR_BITS(iostate.c_cflag, CRTSCTS); #endif /* CRTSCTS */ - if (strncasecmp(value, "NONE", vlen) == 0) { + if (Tcl_UtfNcasecmp(value, "NONE", vlen) == 0) { /* * Leave all handshake options disabled. */ - } else if (strncasecmp(value, "XONXOFF", vlen) == 0) { + } else if (Tcl_UtfNcasecmp(value, "XONXOFF", vlen) == 0) { SET_BITS(iostate.c_iflag, IXON | IXOFF | IXANY); - } else if (strncasecmp(value, "RTSCTS", vlen) == 0) { + } else if (Tcl_UtfNcasecmp(value, "RTSCTS", vlen) == 0) { #ifdef CRTSCTS SET_BITS(iostate.c_cflag, CRTSCTS); #else /* !CRTSTS */ UNSUPPORTED_OPTION("-handshake RTSCTS"); return TCL_ERROR; #endif /* CRTSCTS */ - } else if (strncasecmp(value, "DTRDSR", vlen) == 0) { + } else if (Tcl_UtfNcasecmp(value, "DTRDSR", vlen) == 0) { UNSUPPORTED_OPTION("-handshake DTRDSR"); return TCL_ERROR; } else { @@ -705,7 +646,7 @@ TtySetOptionProc( } return TCL_ERROR; } - SETIOSTATE(fsPtr->fd, &iostate); + tcsetattr(fsPtr->fd, TCSADRAIN, &iostate); return TCL_OK; } @@ -730,7 +671,7 @@ TtySetOptionProc( return TCL_ERROR; } - GETIOSTATE(fsPtr->fd, &iostate); + tcgetattr(fsPtr->fd, &iostate); Tcl_UtfToExternalDString(NULL, argv[0], -1, &ds); iostate.c_cc[VSTART] = *(const cc_t *) Tcl_DStringValue(&ds); @@ -741,7 +682,7 @@ TtySetOptionProc( Tcl_DStringFree(&ds); ckfree(argv); - SETIOSTATE(fsPtr->fd, &iostate); + tcsetattr(fsPtr->fd, TCSADRAIN, &iostate); return TCL_OK; } @@ -752,22 +693,22 @@ TtySetOptionProc( if ((len > 2) && (strncmp(optionName, "-timeout", len) == 0)) { int msec; - GETIOSTATE(fsPtr->fd, &iostate); + tcgetattr(fsPtr->fd, &iostate); if (Tcl_GetInt(interp, value, &msec) != TCL_OK) { return TCL_ERROR; } iostate.c_cc[VMIN] = 0; iostate.c_cc[VTIME] = (msec==0) ? 0 : (msec<100) ? 1 : (msec+50)/100; - SETIOSTATE(fsPtr->fd, &iostate); + tcsetattr(fsPtr->fd, TCSADRAIN, &iostate); return TCL_OK; } /* * Option -ttycontrol {DTR 1 RTS 0 BREAK 0} */ - if ((len > 4) && (strncmp(optionName, "-ttycontrol", len) == 0)) { - int i; +#if defined(TIOCMGET) && defined(TIOCMSET) + int i, control, flag; if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) { return TCL_ERROR; @@ -784,44 +725,36 @@ TtySetOptionProc( return TCL_ERROR; } - GETCONTROL(fsPtr->fd, &control); + ioctl(fsPtr->fd, TIOCMGET, &control); for (i = 0; i < argc-1; i += 2) { if (Tcl_GetBoolean(interp, argv[i+1], &flag) == TCL_ERROR) { ckfree(argv); return TCL_ERROR; } - if (strncasecmp(argv[i], "DTR", strlen(argv[i])) == 0) { -#ifdef TIOCM_DTR + if (Tcl_UtfNcasecmp(argv[i], "DTR", strlen(argv[i])) == 0) { if (flag) { SET_BITS(control, TIOCM_DTR); } else { CLEAR_BITS(control, TIOCM_DTR); } -#else /* !TIOCM_DTR */ - UNSUPPORTED_OPTION("-ttycontrol DTR"); - ckfree(argv); - return TCL_ERROR; -#endif /* TIOCM_DTR */ - } else if (strncasecmp(argv[i], "RTS", strlen(argv[i])) == 0) { -#ifdef TIOCM_RTS + } else if (Tcl_UtfNcasecmp(argv[i], "RTS", strlen(argv[i])) == 0) { if (flag) { SET_BITS(control, TIOCM_RTS); } else { CLEAR_BITS(control, TIOCM_RTS); } -#else /* !TIOCM_RTS*/ - UNSUPPORTED_OPTION("-ttycontrol RTS"); - ckfree(argv); - return TCL_ERROR; -#endif /* TIOCM_RTS*/ - } else if (strncasecmp(argv[i], "BREAK", strlen(argv[i])) == 0) { -#ifdef SETBREAK - SETBREAK(fsPtr->fd, flag); -#else /* !SETBREAK */ + } else if (Tcl_UtfNcasecmp(argv[i], "BREAK", strlen(argv[i])) == 0) { +#if defined(TIOCSBRK) && defined(TIOCCBRK) + if (flag) { + ioctl(fsPtr->fd, TIOCSBRK, NULL); + } else { + ioctl(fsPtr->fd, TIOCCBRK, NULL); + } +#else /* TIOCSBRK & TIOCCBRK */ UNSUPPORTED_OPTION("-ttycontrol BREAK"); ckfree(argv); return TCL_ERROR; -#endif /* SETBREAK */ +#endif /* TIOCSBRK & TIOCCBRK */ } else { if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -835,17 +768,16 @@ TtySetOptionProc( } } /* -ttycontrol options loop */ - SETCONTROL(fsPtr->fd, &control); + ioctl(fsPtr->fd, TIOCMSET, &control); ckfree(argv); return TCL_OK; +#else /* TIOCMGET&TIOCMSET */ + UNSUPPORTED_OPTION("-ttycontrol"); +#endif /* TIOCMGET&TIOCMSET */ } return Tcl_BadChannelOption(interp, optionName, "mode handshake timeout ttycontrol xchar"); - -#else /* !USE_TERMIOS */ - return Tcl_BadChannelOption(interp, optionName, "mode"); -#endif /* USE_TERMIOS */ } /* @@ -860,12 +792,8 @@ TtySetOptionProc( * * Results: * A standard Tcl result. Also sets the supplied DString to the string - * value of the option(s) returned. - * - * Side effects: - * The string returned by this function is in static storage and may be - * reused at any time subsequent to the call. Sets error message if - * needed (by calling Tcl_BadChannelOption). + * value of the option(s) returned. Sets error message if needed + * (by calling Tcl_BadChannelOption). * *---------------------------------------------------------------------- */ @@ -899,7 +827,6 @@ TtyGetOptionProc( Tcl_DStringAppendElement(dsPtr, buf); } -#ifdef USE_TERMIOS /* * Get option -xchar */ @@ -909,11 +836,11 @@ TtyGetOptionProc( Tcl_DStringStartSublist(dsPtr); } if (len==0 || (len>1 && strncmp(optionName, "-xchar", len)==0)) { - IOSTATE iostate; + struct termios iostate; Tcl_DString ds; valid = 1; - GETIOSTATE(fsPtr->fd, &iostate); + tcgetattr(fsPtr->fd, &iostate); Tcl_DStringInit(&ds); Tcl_ExternalToUtfDString(NULL, (char *) &iostate.c_cc[VSTART], 1, &ds); @@ -938,12 +865,8 @@ TtyGetOptionProc( int inQueue=0, outQueue=0, inBuffered, outBuffered; valid = 1; -#ifdef GETREADQUEUE GETREADQUEUE(fsPtr->fd, inQueue); -#endif /* GETREADQUEUE */ -#ifdef GETWRITEQUEUE GETWRITEQUEUE(fsPtr->fd, outQueue); -#endif /* GETWRITEQUEUE */ inBuffered = Tcl_InputBuffered(fsPtr->channel); outBuffered = Tcl_OutputBuffered(fsPtr->channel); @@ -953,37 +876,31 @@ TtyGetOptionProc( Tcl_DStringAppendElement(dsPtr, buf); } +#if defined(TIOCMGET) /* * Get option -ttystatus * Option is readonly and returned by [fconfigure chan -ttystatus] but not * returned by unnamed [fconfigure chan]. */ - if ((len > 4) && (strncmp(optionName, "-ttystatus", len) == 0)) { int status; valid = 1; - GETCONTROL(fsPtr->fd, &status); + ioctl(fsPtr->fd, TIOCMGET, &status); TtyModemStatusStr(status, dsPtr); } -#endif /* USE_TERMIOS */ +#endif /* TIOCMGET */ if (valid) { return TCL_OK; } return Tcl_BadChannelOption(interp, optionName, "mode" -#ifdef USE_TERMIOS " queue ttystatus xchar" -#endif /* USE_TERMIOS */ ); } -#ifdef DIRECT_BAUD -# define TtyGetSpeed(baud) ((unsigned) (baud)) -# define TtyGetBaud(speed) ((int) (speed)) -#else /* !DIRECT_BAUD */ -static const struct {int baud; unsigned long speed;} speeds[] = { +static const struct {int baud; speed_t speed;} speeds[] = { #ifdef B0 {0, B0}, #endif @@ -1079,20 +996,16 @@ static const struct {int baud; unsigned long speed;} speeds[] = { * * TtyGetSpeed -- * - * Given a baud rate, get the mask value that should be stored in the - * termios, termio, or sgttyb structure in order to select that baud - * rate. + * Given an integer baud rate, get the speed_t value that should be + * used to select that baud rate. * * Results: * As above. * - * Side effects: - * None. - * *--------------------------------------------------------------------------- */ -static unsigned long +static speed_t TtyGetSpeed( int baud) /* The baud rate to look up. */ { @@ -1125,21 +1038,17 @@ TtyGetSpeed( * * TtyGetBaud -- * - * Given a speed mask value from a termios, termio, or sgttyb structure, - * get the baus rate that corresponds to that mask value. + * Return the integer baud rate corresponding to a given speed_t value. * * Results: * As above. If the mask value was not recognized, 0 is returned. * - * Side effects: - * None. - * *--------------------------------------------------------------------------- */ static int TtyGetBaud( - unsigned long speed) /* Speed mask value to look up. */ + speed_t speed) /* Speed mask value to look up. */ { int i; @@ -1150,7 +1059,6 @@ TtyGetBaud( } return 0; } -#endif /* !DIRECT_BAUD */ /* *--------------------------------------------------------------------------- @@ -1175,12 +1083,11 @@ TtyGetAttributes( TtyAttrs *ttyPtr) /* Buffer filled with serial port * attributes. */ { - IOSTATE iostate; + struct termios iostate; int baud, parity, data, stop; - GETIOSTATE(fd, &iostate); + tcgetattr(fd, &iostate); -#ifdef USE_TERMIOS baud = TtyGetBaud(cfgetospeed(&iostate)); parity = 'n'; @@ -1202,39 +1109,6 @@ TtyGetAttributes( data = (data == CS5) ? 5 : (data == CS6) ? 6 : (data == CS7) ? 7 : 8; stop = (iostate.c_cflag & CSTOPB) ? 2 : 1; -#endif /* USE_TERMIOS */ - -#ifdef USE_TERMIO - baud = TtyGetBaud(iostate.c_cflag & CBAUD); - - parity = 'n'; - switch (iostate.c_cflag & (PARENB | PARODD | PAREXT)) { - case PARENB : parity = 'e'; break; - case PARENB | PARODD : parity = 'o'; break; - case PARENB | PAREXT : parity = 's'; break; - case PARENB | PARODD | PAREXT : parity = 'm'; break; - } - - data = iostate.c_cflag & CSIZE; - data = (data == CS5) ? 5 : (data == CS6) ? 6 : (data == CS7) ? 7 : 8; - - stop = (iostate.c_cflag & CSTOPB) ? 2 : 1; -#endif /* USE_TERMIO */ - -#ifdef USE_SGTTY - baud = TtyGetBaud(iostate.sg_ospeed); - - parity = 'n'; - if (iostate.sg_flags & EVENP) { - parity = 'e'; - } else if (iostate.sg_flags & ODDP) { - parity = 'o'; - } - - data = (iostate.sg_flags & (EVENP | ODDP)) ? 7 : 8; - - stop = 1; -#endif /* USE_SGTTY */ ttyPtr->baud = baud; ttyPtr->parity = parity; @@ -1265,12 +1139,10 @@ TtySetAttributes( TtyAttrs *ttyPtr) /* Buffer containing new attributes for serial * port. */ { - IOSTATE iostate; - -#ifdef USE_TERMIOS + struct termios iostate; int parity, data, flag; - GETIOSTATE(fd, &iostate); + tcgetattr(fd, &iostate); cfsetospeed(&iostate, TtyGetSpeed(ttyPtr->baud)); cfsetispeed(&iostate, TtyGetSpeed(ttyPtr->baud)); @@ -1300,58 +1172,7 @@ TtySetAttributes( CLEAR_BITS(iostate.c_cflag, PARENB | PARODD | CSIZE | CSTOPB); SET_BITS(iostate.c_cflag, flag); -#endif /* USE_TERMIOS */ - -#ifdef USE_TERMIO - int parity, data, flag; - - GETIOSTATE(fd, &iostate); - CLEAR_BITS(iostate.c_cflag, CBAUD); - SET_BITS(iostate.c_cflag, TtyGetSpeed(ttyPtr->baud)); - - flag = 0; - parity = ttyPtr->parity; - if (parity != 'n') { - SET_BITS(flag, PARENB); - if ((parity == 'm') || (parity == 's')) { - SET_BITS(flag, PAREXT); - } - if ((parity == 'm') || (parity == 'o')) { - SET_BITS(flag, PARODD); - } - } - data = ttyPtr->data; - SET_BITS(flag, - (data == 5) ? CS5 : - (data == 6) ? CS6 : - (data == 7) ? CS7 : CS8); - if (ttyPtr->stop == 2) { - SET_BITS(flag, CSTOPB); - } - - CLEAR_BITS(iostate.c_cflag, PARENB | PARODD | PAREXT | CSIZE | CSTOPB); - SET_BITS(iostate.c_cflag, flag); - -#endif /* USE_TERMIO */ - -#ifdef USE_SGTTY - int parity; - - GETIOSTATE(fd, &iostate); - iostate.sg_ospeed = TtyGetSpeed(ttyPtr->baud); - iostate.sg_ispeed = TtyGetSpeed(ttyPtr->baud); - - parity = ttyPtr->parity; - if (parity == 'e') { - CLEAR_BITS(iostate.sg_flags, ODDP); - SET_BITS(iostate.sg_flags, EVENP); - } else if (parity == 'o') { - CLEAR_BITS(iostate.sg_flags, EVENP); - SET_BITS(iostate.sg_flags, ODDP); - } -#endif /* USE_SGTTY */ - - SETIOSTATE(fd, &iostate); + tcsetattr(fd, TCSADRAIN, &iostate); } /* @@ -1367,9 +1188,6 @@ TtySetAttributes( * TCL_ERROR otherwise. If TCL_ERROR is returned, an error message is * left in the interp's result (if interp is non-NULL). * - * Side effects: - * None. - * *--------------------------------------------------------------------------- */ @@ -1377,17 +1195,17 @@ static int TtyParseMode( Tcl_Interp *interp, /* If non-NULL, interp for error return. */ const char *mode, /* Mode string to be parsed. */ - int *speedPtr, /* Filled with baud rate from mode string. */ - int *parityPtr, /* Filled with parity from mode string. */ - int *dataPtr, /* Filled with data bits from mode string. */ - int *stopPtr) /* Filled with stop bits from mode string. */ + TtyAttrs *ttyPtr) /* Filled with data from mode string */ { int i, end; char parity; - static const char *bad = "bad value for -mode"; + const char *bad = "bad value for -mode"; - i = sscanf(mode, "%d,%c,%d,%d%n", speedPtr, &parity, dataPtr, - stopPtr, &end); + i = sscanf(mode, "%d,%c,%d,%d%n", + &ttyPtr->baud, + &parity, + &ttyPtr->data, + &ttyPtr->stop, &end); if ((i != 4) || (mode[end] != '\0')) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -1407,27 +1225,27 @@ TtyParseMode( */ if ( -#if defined(PAREXT) || defined(USE_TERMIO) +#if defined(PAREXT) strchr("noems", parity) #else strchr("noe", parity) -#endif /* PAREXT|USE_TERMIO */ +#endif /* PAREXT */ == NULL) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "%s parity: should be %s", bad, -#if defined(PAREXT) || defined(USE_TERMIO) +#if defined(PAREXT) "n, o, e, m, or s" #else "n, o, or e" -#endif /* PAREXT|USE_TERMIO */ +#endif /* PAREXT */ )); Tcl_SetErrorCode(interp, "TCL", "VALUE", "SERIALMODE", NULL); } return TCL_ERROR; } - *parityPtr = parity; - if ((*dataPtr < 5) || (*dataPtr > 8)) { + ttyPtr->parity = parity; + if ((ttyPtr->data < 5) || (ttyPtr->data > 8)) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "%s data: should be 5, 6, 7, or 8", bad)); @@ -1435,7 +1253,7 @@ TtyParseMode( } return TCL_ERROR; } - if ((*stopPtr < 0) || (*stopPtr > 2)) { + if ((ttyPtr->stop < 0) || (ttyPtr->stop > 2)) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "%s stop: should be 1 or 2", bad)); @@ -1453,71 +1271,38 @@ TtyParseMode( * * Given file descriptor that refers to a serial port, initialize the * serial port to a set of sane values so that Tcl can talk to a device - * located on the serial port. Note that no initialization happens if the - * initialize flag is not set; this is necessary for the correct handling - * of UNIX console TTYs at startup. - * - * Results: - * A pointer to a FileState suitable for use with Tcl_CreateChannel and - * the ttyChannelType structure. + * located on the serial port. * * Side effects: * Serial device initialized to non-blocking raw mode, similar to sockets - * (if initialize flag is non-zero.) All other modes can be simulated on - * top of this in Tcl. + * All other modes can be simulated on top of this in Tcl. * *--------------------------------------------------------------------------- */ -static FileState * +static void TtyInit( - int fd, /* Open file descriptor for serial port to be - * initialized. */ - int initialize) + int fd) /* Open file descriptor for serial port to be initialized. */ { - TtyState *ttyPtr = ckalloc(sizeof(TtyState)); - int stateUpdated = 0; - - GETIOSTATE(fd, &ttyPtr->savedState); - if (initialize) { - IOSTATE iostate = ttyPtr->savedState; - -#if defined(USE_TERMIOS) || defined(USE_TERMIO) - if (iostate.c_iflag != IGNBRK - || iostate.c_oflag != 0 - || iostate.c_lflag != 0 - || iostate.c_cflag & CREAD - || iostate.c_cc[VMIN] != 1 - || iostate.c_cc[VTIME] != 0) { - stateUpdated = 1; - } + struct termios iostate; + tcgetattr(fd, &iostate); + + if (iostate.c_iflag != IGNBRK + || iostate.c_oflag != 0 + || iostate.c_lflag != 0 + || iostate.c_cflag & CREAD + || iostate.c_cc[VMIN] != 1 + || iostate.c_cc[VTIME] != 0) + { iostate.c_iflag = IGNBRK; iostate.c_oflag = 0; iostate.c_lflag = 0; - SET_BITS(iostate.c_cflag, CREAD); + iostate.c_cflag |= CREAD; iostate.c_cc[VMIN] = 1; iostate.c_cc[VTIME] = 0; -#endif /* USE_TERMIOS|USE_TERMIO */ - -#ifdef USE_SGTTY - if ((iostate.sg_flags & (EVENP | ODDP)) - || !(iostate.sg_flags & RAW)) { - ttyPtr->stateUpdated = 1; - } - iostate.sg_flags &= EVENP | ODDP; - SET_BITS(iostate.sg_flags, RAW); -#endif /* USE_SGTTY */ - - /* - * Only update if we're changing anything to avoid possible blocking. - */ - if (stateUpdated) { - SETIOSTATE(fd, &iostate); - } + tcsetattr(fd, TCSADRAIN, &iostate); } - - return &ttyPtr->fs; } #endif /* SUPPORTS_TTY */ @@ -1621,15 +1406,15 @@ TclpOpenFileChannel( translation = "auto crlf"; channelTypePtr = &ttyChannelType; - fsPtr = TtyInit(fd, 1); + TtyInit(fd); } else #endif /* SUPPORTS_TTY */ { translation = NULL; channelTypePtr = &fileChannelType; - fsPtr = ckalloc(sizeof(FileState)); } + fsPtr = ckalloc(sizeof(FileState)); fsPtr->validMask = channelPermissions | TCL_EXCEPTION; fsPtr->fd = fd; @@ -1692,7 +1477,6 @@ Tcl_MakeFileChannel( #ifdef SUPPORTS_TTY if (isatty(fd)) { - fsPtr = TtyInit(fd, 0); channelTypePtr = &ttyChannelType; sprintf(channelName, "serial%d", fd); } else @@ -1703,10 +1487,10 @@ Tcl_MakeFileChannel( return TclpMakeTcpClientChannelMode(INT2PTR(fd), mode); } else { channelTypePtr = &fileChannelType; - fsPtr = ckalloc(sizeof(FileState)); sprintf(channelName, "file%d", fd); } + fsPtr = ckalloc(sizeof(FileState)); fsPtr->fd = fd; fsPtr->validMask = mode | TCL_EXCEPTION; fsPtr->channel = Tcl_CreateChannel(channelTypePtr, channelName, diff --git a/unix/tclUnixCompat.c b/unix/tclUnixCompat.c index e201018..e5929ba 100644 --- a/unix/tclUnixCompat.c +++ b/unix/tclUnixCompat.c @@ -8,8 +8,6 @@ */ #include "tclInt.h" -#include <pwd.h> -#include <grp.h> #include <errno.h> #include <string.h> @@ -49,7 +47,7 @@ #ifdef TCL_THREADS -typedef struct ThreadSpecificData { +typedef struct { struct passwd pwd; #if defined(HAVE_GETPWNAM_R_5) || defined(HAVE_GETPWUID_R_5) #define NEED_PW_CLEANER 1 @@ -995,12 +993,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..3c6d3f9 100644 --- a/unix/tclUnixFCmd.c +++ b/unix/tclUnixFCmd.c @@ -41,8 +41,6 @@ */ #include "tclInt.h" -#include <utime.h> -#include <grp.h> #ifndef HAVE_STRUCT_STAT_ST_BLKSIZE #ifndef NO_FSTATFS #include <sys/statfs.h> @@ -244,7 +242,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__) && \ @@ -1340,7 +1338,7 @@ GetGroupAttribute( groupPtr = TclpGetGrGid(statBuf.st_gid); if (groupPtr == NULL) { - *attributePtrPtr = Tcl_NewIntObj((int) statBuf.st_gid); + *attributePtrPtr = Tcl_NewLongObj((long) statBuf.st_gid); } else { Tcl_DString ds; const char *utf; @@ -1394,7 +1392,7 @@ GetOwnerAttribute( pwPtr = TclpGetPwUid(statBuf.st_uid); if (pwPtr == NULL) { - *attributePtrPtr = Tcl_NewIntObj((int) statBuf.st_uid); + *attributePtrPtr = Tcl_NewLongObj((long) statBuf.st_uid); } else { Tcl_DString ds; @@ -2285,7 +2283,7 @@ GetReadOnlyAttribute( return TCL_ERROR; } - *attributePtrPtr = Tcl_NewBooleanObj(statBuf.st_flags&UF_IMMUTABLE); + *attributePtrPtr = Tcl_NewLongObj((statBuf.st_flags&UF_IMMUTABLE)!=0); return TCL_OK; } diff --git a/unix/tclUnixFile.c b/unix/tclUnixFile.c index 38504d9..5bfe5d9 100644 --- a/unix/tclUnixFile.c +++ b/unix/tclUnixFile.c @@ -1181,9 +1181,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 +1204,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..39be160 100644 --- a/unix/tclUnixInit.c +++ b/unix/tclUnixInit.c @@ -42,12 +42,12 @@ static const char *const platforms[NUMPLATFORMS] = { }; #define NUMPROCESSORS 11 -static const char *const processors[NUMPROCESSORS] = { +static const char *const processors[NUMPROCESSORS] = { "intel", "mips", "alpha", "ppc", "shx", "arm", "ia64", "alpha64", "msil", "amd64", "ia32_on_win64" }; -typedef struct _SYSTEM_INFO { +typedef struct { union { DWORD dwOemId; struct { @@ -66,7 +66,7 @@ typedef struct _SYSTEM_INFO { int wProcessorRevision; } SYSTEM_INFO; -typedef struct _OSVERSIONINFOA { +typedef struct { DWORD dwOSVersionInfoSize; DWORD dwMajorVersion; DWORD dwMinorVersion; @@ -112,7 +112,7 @@ static char pkgPath[sizeof(TCL_PACKAGE_PATH)+200] = TCL_PACKAGE_PATH; * first list checked for a mapping from env encoding to Tcl encoding name. */ -typedef struct LocaleTable { +typedef struct { const char *lang; const char *encoding; } LocaleTable; diff --git a/unix/tclUnixNotfy.c b/unix/tclUnixNotfy.c index b87af1b..6e90807 100644 --- a/unix/tclUnixNotfy.c +++ b/unix/tclUnixNotfy.c @@ -39,7 +39,7 @@ typedef struct FileHandler { * handlers are ready to fire. */ -typedef struct FileHandlerEvent { +typedef struct { Tcl_Event header; /* Information that is standard for all * events. */ int fd; /* File descriptor that is ready. Used to find @@ -54,7 +54,7 @@ typedef struct FileHandlerEvent { * writable, and exception conditions. */ -typedef struct SelectMasks { +typedef struct { fd_set readable; fd_set writable; fd_set exception; @@ -213,14 +213,14 @@ typedef struct { void *hCursor; void *hbrBackground; void *lpszMenuName; - void *lpszClassName; + const void *lpszClassName; } WNDCLASS; extern void __stdcall CloseHandle(void *); extern void *__stdcall CreateEventW(void *, unsigned char, unsigned char, void *); -extern void * __stdcall CreateWindowExW(void *, void *, void *, DWORD, int, - int, int, int, void *, void *, void *, void *); +extern void * __stdcall CreateWindowExW(void *, const void *, const void *, + DWORD, int, int, int, int, void *, void *, void *, void *); extern DWORD __stdcall DefWindowProcW(void *, int, void *, void *); extern unsigned char __stdcall DestroyWindow(void *); extern int __stdcall DispatchMessageW(const MSG *); diff --git a/unix/tclUnixPipe.c b/unix/tclUnixPipe.c index 9c21b28..ac9ba77 100644 --- a/unix/tclUnixPipe.c +++ b/unix/tclUnixPipe.c @@ -30,7 +30,7 @@ * This structure describes per-instance state of a pipe based channel. */ -typedef struct PipeState { +typedef struct { Tcl_Channel channel; /* Channel associated with this file. */ TclFile inFile; /* Output from pipe. */ TclFile outFile; /* Input to pipe. */ @@ -870,7 +870,7 @@ TclGetAndDetachPids( pipePtr = Tcl_GetChannelInstanceData(chan); TclNewObj(pidsObj); for (i = 0; i < pipePtr->numPids; i++) { - Tcl_ListObjAppendElement(NULL, pidsObj, Tcl_NewIntObj( + Tcl_ListObjAppendElement(NULL, pidsObj, Tcl_NewLongObj( PTR2INT(pipePtr->pidPtr[i]))); Tcl_DetachPids(1, &pipePtr->pidPtr[i]); } @@ -1288,7 +1288,7 @@ Tcl_PidObjCmd( resultPtr = Tcl_NewObj(); for (i = 0; i < pipePtr->numPids; i++) { Tcl_ListObjAppendElement(NULL, resultPtr, - Tcl_NewIntObj(PTR2INT(TclpGetPid(pipePtr->pidPtr[i])))); + Tcl_NewLongObj(PTR2INT(TclpGetPid(pipePtr->pidPtr[i])))); } Tcl_SetObjResult(interp, resultPtr); } diff --git a/unix/tclUnixPort.h b/unix/tclUnixPort.h index 63c500d..636c760 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 @@ -584,19 +578,6 @@ extern char ** environ; /* *--------------------------------------------------------------------------- - * The termios configure test program relies on the configure script being run - * from a terminal, which is not the case e.g., when configuring from Xcode. - * Since termios is known to be present on all Mac OS X releases since 10.0, - * override the configure defines for serial API here. [Bug 497147] - *--------------------------------------------------------------------------- - */ - -# define USE_TERMIOS 1 -# undef USE_TERMIO -# undef USE_SGTTY - -/* - *--------------------------------------------------------------------------- * Include AvailabilityMacros.h here (when available) to ensure any symbolic * MAC_OS_X_VERSION_* constants passed on the command line are translated. *--------------------------------------------------------------------------- @@ -737,15 +718,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..fcfe18e 100644 --- a/unix/tclUnixTest.c +++ b/unix/tclUnixTest.c @@ -37,7 +37,7 @@ * exercised by the "testfilehandler" command. */ -typedef struct Pipe { +typedef struct { TclFile readFile; /* File handle for reading from the pipe. NULL * means pipe doesn't exist yet. */ TclFile writeFile; /* File handle for writing from the pipe. */ @@ -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/tclUnixThrd.c b/unix/tclUnixThrd.c index 789dbb6..9a1efbe 100644 --- a/unix/tclUnixThrd.c +++ b/unix/tclUnixThrd.c @@ -15,7 +15,7 @@ #ifdef TCL_THREADS -typedef struct ThreadSpecificData { +typedef struct { char nabuf[16]; } ThreadSpecificData; @@ -683,7 +683,7 @@ TclpInetNtoa( static volatile int initialized = 0; static pthread_key_t key; -typedef struct allocMutex { +typedef struct { Tcl_Mutex tlock; pthread_mutex_t plock; } allocMutex; @@ -691,10 +691,10 @@ typedef struct allocMutex { Tcl_Mutex * TclpNewAllocMutex(void) { - struct allocMutex *lockPtr; + allocMutex *lockPtr; register pthread_mutex_t *plockPtr; - lockPtr = malloc(sizeof(struct allocMutex)); + lockPtr = malloc(sizeof(allocMutex)); if (lockPtr == NULL) { Tcl_Panic("could not allocate lock"); } diff --git a/unix/tclUnixTime.c b/unix/tclUnixTime.c index 6e8c5f4..27b6a58 100644 --- a/unix/tclUnixTime.c +++ b/unix/tclUnixTime.c @@ -16,26 +16,10 @@ #include <mach/mach_time.h> #endif -#define TM_YEAR_BASE 1900 -#define IsLeapYear(x) (((x)%4 == 0) && ((x)%100 != 0 || (x)%400 == 0)) - -/* - * If we fall back on the thread-unsafe versions of gmtime and localtime, use - * this mutex to try to protect them. - */ - -TCL_DECLARE_MUTEX(tmMutex) - -static char *lastTZ = NULL; /* Holds the last setting of the TZ - * environment variable, or an empty string if - * the variable was not set. */ - /* * Static functions declared in this file. */ -static void SetTZIfNecessary(void); -static void CleanupMemory(ClientData clientData); static void NativeScaleTime(Tcl_Time *timebuf, ClientData clientData); static void NativeGetTime(Tcl_Time *timebuf, @@ -350,70 +334,6 @@ NativeGetTime( timePtr->sec = tv.tv_sec; timePtr->usec = tv.tv_usec; } -/* - *---------------------------------------------------------------------- - * - * SetTZIfNecessary -- - * - * Determines whether a call to 'tzset' is needed prior to the next call - * to 'localtime' or examination of the 'timezone' variable. - * - * Results: - * None. - * - * Side effects: - * If 'tzset' has never been called in the current process, or if the - * value of the environment variable TZ has changed since the last call - * to 'tzset', then 'tzset' is called again. - * - *---------------------------------------------------------------------- - */ - -static void -SetTZIfNecessary(void) -{ - const char *newTZ = getenv("TZ"); - - Tcl_MutexLock(&tmMutex); - if (newTZ == NULL) { - newTZ = ""; - } - if (lastTZ == NULL || strcmp(lastTZ, newTZ)) { - tzset(); - if (lastTZ == NULL) { - Tcl_CreateExitHandler(CleanupMemory, NULL); - } else { - Tcl_Free(lastTZ); - } - lastTZ = ckalloc(strlen(newTZ) + 1); - strcpy(lastTZ, newTZ); - } - Tcl_MutexUnlock(&tmMutex); -} - -/* - *---------------------------------------------------------------------- - * - * CleanupMemory -- - * - * Releases the private copy of the TZ environment variable upon exit - * from Tcl. - * - * Results: - * None. - * - * Side effects: - * Frees allocated memory. - * - *---------------------------------------------------------------------- - */ - -static void -CleanupMemory( - ClientData ignored) -{ - ckfree(lastTZ); -} /* * Local Variables: 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..4d19bb2 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,19 +639,19 @@ 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 \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/opt0.4"; \ done; - @echo "Installing package msgcat 1.5.0 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.5.0.tm; + @echo "Installing package msgcat 1.5.1 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.5.1.tm; @echo "Installing package tcltest 2.3.5 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.3.5.tm; - @echo "Installing package platform 1.0.10 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/platform/platform.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/platform-1.0.10.tm; + @echo "Installing package platform 1.0.11 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/platform/platform.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/platform-1.0.11.tm; @echo "Installing package platform::shell 1.1.4 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/platform/shell.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/platform/shell-1.1.4.tm; @echo "Installing encodings"; @@ -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); ) \ diff --git a/win/configure b/win/configure index ba10113..8b5fdaa 100755 --- a/win/configure +++ b/win/configure @@ -3146,7 +3146,8 @@ echo "${ECHO_T}shared" >&6 echo "$as_me:$LINENO: result: static" >&5 echo "${ECHO_T}static" >&6 SHARED_BUILD=0 - cat >>confdefs.h <<\_ACEOF + +cat >>confdefs.h <<\_ACEOF #define STATIC_BUILD 1 _ACEOF @@ -3646,7 +3647,7 @@ echo "$as_me: error: ${CC} does not support the -shared option. CFLAGS_DEBUG=-g CFLAGS_OPTIMIZE="-O2 -fomit-frame-pointer" - CFLAGS_WARNING="-Wall -Wdeclaration-after-statement" + CFLAGS_WARNING="-Wall -Wwrite-strings -Wdeclaration-after-statement" LDFLAGS_DEBUG= LDFLAGS_OPTIMIZE= @@ -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 ]) #------------------------------------------------------------------------ @@ -103,13 +255,13 @@ AC_DEFUN([SC_PATH_TKCONFIG], [ #------------------------------------------------------------------------ AC_DEFUN([SC_LOAD_TCLCONFIG], [ - AC_MSG_CHECKING([for existence of $TCL_BIN_DIR/tclConfig.sh]) + AC_MSG_CHECKING([for existence of ${TCL_BIN_DIR}/tclConfig.sh]) - if test -f "$TCL_BIN_DIR/tclConfig.sh" ; then + if test -f "${TCL_BIN_DIR}/tclConfig.sh" ; then AC_MSG_RESULT([loading]) - . $TCL_BIN_DIR/tclConfig.sh + . "${TCL_BIN_DIR}/tclConfig.sh" else - AC_MSG_RESULT([file not found]) + AC_MSG_RESULT([could not find ${TCL_BIN_DIR}/tclConfig.sh]) fi # @@ -158,7 +310,6 @@ AC_DEFUN([SC_LOAD_TCLCONFIG], [ # SC_LOAD_TKCONFIG -- # # Load the tkConfig.sh file -# Currently a no-op for Windows # # Arguments: # @@ -172,13 +323,13 @@ AC_DEFUN([SC_LOAD_TCLCONFIG], [ #------------------------------------------------------------------------ AC_DEFUN([SC_LOAD_TKCONFIG], [ - AC_MSG_CHECKING([for existence of $TK_BIN_DIR/tkConfig.sh]) + AC_MSG_CHECKING([for existence of ${TK_BIN_DIR}/tkConfig.sh]) - if test -f "$TK_BIN_DIR/tkConfig.sh" ; then + if test -f "${TK_BIN_DIR}/tkConfig.sh" ; then AC_MSG_RESULT([loading]) - . $TK_BIN_DIR/tkConfig.sh + . "${TK_BIN_DIR}/tkConfig.sh" else - AC_MSG_RESULT([could not find $TK_BIN_DIR/tkConfig.sh]) + AC_MSG_RESULT([could not find ${TK_BIN_DIR}/tkConfig.sh]) fi @@ -212,7 +363,7 @@ AC_DEFUN([SC_ENABLE_SHARED], [ AC_MSG_CHECKING([how to build libraries]) AC_ARG_ENABLE(shared, [ --enable-shared build and link with shared libraries (default: on)], - [tcl_ok=$enableval], [tcl_ok=yes]) + [tcl_ok=$enableval], [tcl_ok=yes]) if test "${enable_shared+set}" = set; then enableval="$enable_shared" @@ -227,7 +378,7 @@ AC_DEFUN([SC_ENABLE_SHARED], [ else AC_MSG_RESULT([static]) SHARED_BUILD=0 - AC_DEFINE(STATIC_BUILD) + AC_DEFINE(STATIC_BUILD, 1, [Is this a static build?]) fi ]) @@ -270,7 +421,7 @@ AC_DEFUN([SC_ENABLE_THREADS], [ #------------------------------------------------------------------------ # SC_ENABLE_SYMBOLS -- # -# Specify if debugging symbols should be used +# Specify if debugging symbols should be used. # Memory (TCL_MEM_DEBUG) and compile (TCL_COMPILE_DEBUG) debugging # can also be enabled. # @@ -576,7 +727,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ CFLAGS_DEBUG=-g CFLAGS_OPTIMIZE="-O2 -fomit-frame-pointer" - CFLAGS_WARNING="-Wall -Wdeclaration-after-statement" + CFLAGS_WARNING="-Wall -Wwrite-strings -Wdeclaration-after-statement" LDFLAGS_DEBUG= LDFLAGS_OPTIMIZE= diff --git a/win/tclAppInit.c b/win/tclAppInit.c index 5ecebea..753eaff 100644 --- a/win/tclAppInit.c +++ b/win/tclAppInit.c @@ -45,7 +45,10 @@ static void setargv(int *argcPtr, TCHAR ***argvPtr); #ifndef TCL_LOCAL_APPINIT #define TCL_LOCAL_APPINIT Tcl_AppInit #endif -extern int TCL_LOCAL_APPINIT(Tcl_Interp *interp); +#ifndef MODULE_SCOPE +# define MODULE_SCOPE extern +#endif +MODULE_SCOPE int TCL_LOCAL_APPINIT(Tcl_Interp *); /* * The following #if block allows you to change how Tcl finds the startup @@ -54,7 +57,7 @@ extern int TCL_LOCAL_APPINIT(Tcl_Interp *interp); */ #ifdef TCL_LOCAL_MAIN_HOOK -extern int TCL_LOCAL_MAIN_HOOK(int *argc, TCHAR ***argv); +MODULE_SCOPE int TCL_LOCAL_MAIN_HOOK(int *argc, TCHAR ***argv); #endif /* @@ -193,7 +196,8 @@ Tcl_AppInit( * specific startup file will be run under any conditions. */ - (Tcl_SetVar2)(interp, "tcl_rcFileName", NULL, "~/tclshrc.tcl", TCL_GLOBAL_ONLY); + (Tcl_ObjSetVar2)(interp, Tcl_NewStringObj("tcl_rcFileName", -1), NULL, + Tcl_NewStringObj("~/tclshrc.tcl", -1), TCL_GLOBAL_ONLY); return TCL_OK; } diff --git a/win/tclWinChan.c b/win/tclWinChan.c index 52b9e32..e8f46ef 100644 --- a/win/tclWinChan.c +++ b/win/tclWinChan.c @@ -43,7 +43,7 @@ typedef struct FileInfo { * pending on the channel. */ } FileInfo; -typedef struct ThreadSpecificData { +typedef struct { /* * List of all file channels currently open. */ @@ -58,7 +58,7 @@ static Tcl_ThreadDataKey dataKey; * events are generated. */ -typedef struct FileEvent { +typedef struct { Tcl_Event header; /* Information that is standard for all * events. */ FileInfo *infoPtr; /* Pointer to file info structure. Note that diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index 5aab255..a2d0e40 100644 --- a/win/tclWinConsole.c +++ b/win/tclWinConsole.c @@ -11,7 +11,6 @@ */ #include "tclWinInt.h" -#include <sys/stat.h> /* * The following variable is used to tell whether this module has been @@ -50,7 +49,7 @@ TCL_DECLARE_MUTEX(consoleMutex) * threads. */ -typedef struct ConsoleThreadInfo { +typedef struct { HANDLE thread; /* Handle to reader or writer thread. */ HANDLE readyEvent; /* Manual-reset event to signal _to_ the main * thread when the worker thread has finished @@ -113,7 +112,7 @@ typedef struct ConsoleInfo { /* Data consumed by reader thread. */ } ConsoleInfo; -typedef struct ThreadSpecificData { +typedef struct{ /* * The following pointer refers to the head of the list of consoles that * are being watched for file events. @@ -129,7 +128,7 @@ static Tcl_ThreadDataKey dataKey; * console events are generated. */ -typedef struct ConsoleEvent { +typedef struct { Tcl_Event header; /* Information that is standard for all * events. */ ConsoleInfo *infoPtr; /* Pointer to console info structure. Note diff --git a/win/tclWinDde.c b/win/tclWinDde.c index 9b3872e..3f953ce 100644 --- a/win/tclWinDde.c +++ b/win/tclWinDde.c @@ -11,8 +11,9 @@ */ #undef STATIC_BUILD -#undef USE_TCL_STUBS -#define USE_TCL_STUBS +#ifndef USE_TCL_STUBS +# define USE_TCL_STUBS +#endif #include "tclInt.h" #include <dde.h> #include <ddeml.h> @@ -58,7 +59,7 @@ typedef struct Conversation { Tcl_Obj *returnPackagePtr; /* The result package for this conversation. */ } Conversation; -typedef struct DdeEnumServices { +typedef struct { Tcl_Interp *interp; int result; ATOM service; @@ -66,7 +67,7 @@ typedef struct DdeEnumServices { HWND hwnd; } DdeEnumServices; -typedef struct ThreadSpecificData { +typedef struct { Conversation *currentConversations; /* A list of conversations currently being * processed. */ @@ -103,7 +104,7 @@ TCL_DECLARE_MUTEX(ddeMutex) static LRESULT CALLBACK DdeClientWindowProc(HWND hwnd, UINT uMsg, WPARAM wParam, LPARAM lParam); -static int DdeCreateClient(struct DdeEnumServices *es); +static int DdeCreateClient(DdeEnumServices *es); static BOOL CALLBACK DdeEnumWindowsCallback(HWND hwndTarget, LPARAM lParam); static void DdeExitProc(ClientData clientData); @@ -147,20 +148,13 @@ int Dde_Init( Tcl_Interp *interp) { - if (!Tcl_InitStubs(interp, TCL_VERSION, 0)) { + if (Tcl_InitStubs(interp, "8.5", 0) == NULL) { return TCL_ERROR; } -#ifdef UNICODE - if (TclWinGetPlatformId() < VER_PLATFORM_WIN32_NT) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "Win32s and Windows 9x are not supported platforms", -1)); - return TCL_ERROR; - } -#endif Tcl_CreateObjCommand(interp, "dde", DdeObjCmd, NULL, NULL); Tcl_CreateExitHandler(DdeExitProc, NULL); - return Tcl_PkgProvide(interp, TCL_DDE_PACKAGE_NAME, TCL_DDE_VERSION); + return Tcl_PkgProvideEx(interp, TCL_DDE_PACKAGE_NAME, TCL_DDE_VERSION, NULL); } /* @@ -375,7 +369,8 @@ DdeSetServerName( Tcl_DStringSetLength(&dString, offset + sizeof(TCHAR) * TCL_INTEGER_SPACE); actualName = (TCHAR *) Tcl_DStringValue(&dString); } - _stprintf((TCHAR *) (Tcl_DStringValue(&dString) + offset), TEXT("%d"), suffix); + _sntprintf((TCHAR *) (Tcl_DStringValue(&dString) + offset), + TCL_INTEGER_SPACE, TEXT("%d"), suffix); } /* @@ -385,9 +380,12 @@ DdeSetServerName( for (n = 0; n < srvCount; ++n) { Tcl_Obj* namePtr; Tcl_DString ds; + const char *nameStr; + int len; Tcl_ListObjIndex(interp, srvPtrPtr[n], 1, &namePtr); - Tcl_WinUtfToTChar(Tcl_GetString(namePtr), -1, &ds); + nameStr = Tcl_GetStringFromObj(namePtr, &len); + Tcl_WinUtfToTChar(nameStr, len, &ds); if (_tcscmp(actualName, (TCHAR *)Tcl_DStringValue(&ds)) == 0) { suffix++; Tcl_DStringFree(&ds); @@ -572,18 +570,26 @@ ExecuteRemoteObject( returnPackagePtr = Tcl_NewListObj(0, NULL); Tcl_ListObjAppendElement(NULL, returnPackagePtr, - Tcl_NewIntObj(result)); + Tcl_NewLongObj(result)); Tcl_ListObjAppendElement(NULL, returnPackagePtr, Tcl_GetObjResult(riPtr->interp)); if (result == TCL_ERROR) { - Tcl_Obj *errorObjPtr = Tcl_GetVar2Ex(riPtr->interp, "errorCode", NULL, + Tcl_Obj *errorObjPtr; + Tcl_Obj *varName = Tcl_NewStringObj("errorCode", -1); + + Tcl_IncrRefCount(varName); + errorObjPtr = Tcl_ObjGetVar2(riPtr->interp, varName, NULL, TCL_GLOBAL_ONLY); + Tcl_DecrRefCount(varName); if (errorObjPtr) { Tcl_ListObjAppendElement(NULL, returnPackagePtr, errorObjPtr); } - errorObjPtr = Tcl_GetVar2Ex(riPtr->interp, "errorInfo", NULL, + varName = Tcl_NewStringObj("errorInfo", -1); + Tcl_IncrRefCount(varName); + errorObjPtr = Tcl_ObjGetVar2(riPtr->interp, varName, NULL, TCL_GLOBAL_ONLY); + Tcl_DecrRefCount(varName); if (errorObjPtr) { Tcl_ListObjAppendElement(NULL, returnPackagePtr, errorObjPtr); } @@ -746,7 +752,7 @@ DdeServerProc( } else { returnString = (char *) Tcl_GetUnicodeFromObj(convPtr->returnPackagePtr, &len); - len = sizeof(TCHAR) * len + 1; + len = 2 * len + 1; } ddeReturn = DdeCreateDataHandle(ddeInstance, (BYTE *)returnString, (DWORD) len+1, 0, ddeItem, uFmt, 0); @@ -756,10 +762,15 @@ DdeServerProc( } else { Tcl_DString ds; Tcl_Obj *variableObjPtr; + Tcl_Obj *varName; + Tcl_WinTCharToUtf(utilString, -1, &ds); - variableObjPtr = Tcl_GetVar2Ex( - convPtr->riPtr->interp, Tcl_DStringValue(&ds), NULL, + varName = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1); + Tcl_IncrRefCount(varName); + variableObjPtr = Tcl_ObjGetVar2( + convPtr->riPtr->interp, varName, NULL, TCL_GLOBAL_ONLY); + Tcl_DecrRefCount(varName); if (variableObjPtr != NULL) { if (uFmt == CF_TEXT) { returnString = Tcl_GetStringFromObj( @@ -767,7 +778,7 @@ DdeServerProc( } else { returnString = (char *) Tcl_GetUnicodeFromObj( variableObjPtr, &len); - len = sizeof(TCHAR) * len + 1; + len = 2 * len + 1; } ddeReturn = DdeCreateDataHandle(ddeInstance, (BYTE *)returnString, (DWORD) len+1, 0, ddeItem, @@ -804,6 +815,7 @@ DdeServerProc( if (convPtr && !Tcl_IsSafe(convPtr->riPtr->interp)) { Tcl_DString ds; Tcl_Obj *variableObjPtr; + Tcl_Obj *varName; len = DdeQueryString(ddeInstance, ddeItem, NULL, 0, CP_WINUNICODE); Tcl_DStringInit(&dString); @@ -819,9 +831,11 @@ DdeServerProc( variableObjPtr = Tcl_NewUnicodeObj(utilString, -1); } - Tcl_SetVar2Ex(convPtr->riPtr->interp, Tcl_DStringValue(&ds), NULL, + varName = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1); + Tcl_IncrRefCount(varName); + Tcl_ObjSetVar2(convPtr->riPtr->interp, varName, NULL, variableObjPtr, TCL_GLOBAL_ONLY); - + Tcl_DecrRefCount(varName); Tcl_DStringFree(&ds); Tcl_DStringFree(&dString); ddeReturn = (HDDEDATA) DDE_FACK; @@ -1028,7 +1042,7 @@ MakeDdeConnection( static int DdeCreateClient( - struct DdeEnumServices *es) + DdeEnumServices *es) { WNDCLASSEX wc; static const TCHAR *szDdeClientClassName = TEXT("TclEval client class"); @@ -1038,7 +1052,7 @@ DdeCreateClient( wc.cbSize = sizeof(wc); wc.lpfnWndProc = DdeClientWindowProc; wc.lpszClassName = szDdeClientClassName; - wc.cbWndExtra = sizeof(struct DdeEnumServices *); + wc.cbWndExtra = sizeof(DdeEnumServices *); /* * Register and create the callback window. @@ -1060,8 +1074,8 @@ DdeClientWindowProc( switch (uMsg) { case WM_CREATE: { LPCREATESTRUCT lpcs = (LPCREATESTRUCT) lParam; - struct DdeEnumServices *es = - (struct DdeEnumServices *) lpcs->lpCreateParams; + DdeEnumServices *es = + (DdeEnumServices *) lpcs->lpCreateParams; #ifdef _WIN64 SetWindowLongPtr(hwnd, GWLP_USERDATA, (LONG_PTR) es); @@ -1086,14 +1100,14 @@ DdeServicesOnAck( HWND hwndRemote = (HWND)wParam; ATOM service = (ATOM)LOWORD(lParam); ATOM topic = (ATOM)HIWORD(lParam); - struct DdeEnumServices *es; + DdeEnumServices *es; TCHAR sz[255]; Tcl_DString dString; #ifdef _WIN64 - es = (struct DdeEnumServices *) GetWindowLongPtr(hwnd, GWLP_USERDATA); + es = (DdeEnumServices *) GetWindowLongPtr(hwnd, GWLP_USERDATA); #else - es = (struct DdeEnumServices *) GetWindowLong(hwnd, GWL_USERDATA); + es = (DdeEnumServices *) GetWindowLong(hwnd, GWL_USERDATA); #endif if ((es->service == (ATOM)0 || es->service == service) @@ -1144,7 +1158,7 @@ DdeEnumWindowsCallback( LPARAM lParam) { DWORD_PTR dwResult = 0; - struct DdeEnumServices *es = (struct DdeEnumServices *) lParam; + DdeEnumServices *es = (DdeEnumServices *) lParam; SendMessageTimeout(hwndTarget, WM_DDE_INITIATE, (WPARAM)es->hwnd, MAKELONG(es->service, es->topic), SMTO_ABORTIFHUNG, 1000, @@ -1158,7 +1172,7 @@ DdeGetServicesList( const TCHAR *serviceName, const TCHAR *topicName) { - struct DdeEnumServices es; + DdeEnumServices es; es.interp = interp; es.result = TCL_OK; @@ -1298,16 +1312,16 @@ DdeObjCmd( return TCL_ERROR; } - if (Tcl_GetIndexFromObj(interp, objv[1], ddeCommands, "command", 0, - &index) != TCL_OK) { + if (Tcl_GetIndexFromObjStruct(interp, objv[1], ddeCommands, + sizeof(char *), "command", 0, &index) != TCL_OK) { return TCL_ERROR; } switch ((enum DdeSubcommands) index) { case DDE_SERVERNAME: for (i = 2; i < objc; i++) { - if (Tcl_GetIndexFromObj(interp, objv[i], ddeSrvOptions, - "option", 0, &argIndex) != TCL_OK) { + if (Tcl_GetIndexFromObjStruct(interp, objv[i], ddeSrvOptions, + sizeof(char *), "option", 0, &argIndex) != TCL_OK) { /* * If it is the last argument, it might be a server name * instead of a bad argument. @@ -1355,8 +1369,8 @@ DdeObjCmd( } else if (objc >= 6 && objc <= 7) { firstArg = objc - 3; for (i = 2; i < firstArg; i++) { - if (Tcl_GetIndexFromObj(interp, objv[i], ddeExecOptions, - "option", 0, &argIndex) != TCL_OK) { + if (Tcl_GetIndexFromObjStruct(interp, objv[i], ddeExecOptions, + sizeof(char *), "option", 0, &argIndex) != TCL_OK) { goto wrongDdeExecuteArgs; } if (argIndex == DDE_EXEC_ASYNC) { @@ -1376,8 +1390,8 @@ DdeObjCmd( if (objc == 6) { firstArg = 2; break; - } else if ((objc == 7) && (Tcl_GetIndexFromObj(NULL, objv[2], - ddeReqOptions, "option", 0, &argIndex) == TCL_OK)) { + } else if ((objc == 7) && (Tcl_GetIndexFromObjStruct(NULL, objv[2], + ddeReqOptions, sizeof(char *), "option", 0, &argIndex) == TCL_OK)) { flags |= DDE_FLAG_BINARY; firstArg = 3; break; @@ -1394,8 +1408,8 @@ DdeObjCmd( if (objc == 5) { firstArg = 2; break; - } else if ((objc == 6) && (Tcl_GetIndexFromObj(NULL, objv[2], - ddeReqOptions, "option", 0, &argIndex) == TCL_OK)) { + } else if ((objc == 6) && (Tcl_GetIndexFromObjStruct(NULL, objv[2], + ddeReqOptions, sizeof(char *), "option", 0, &argIndex) == TCL_OK)) { flags |= DDE_FLAG_BINARY; firstArg = 3; break; @@ -1422,8 +1436,8 @@ DdeObjCmd( return TCL_ERROR; } else { firstArg = 2; - if (Tcl_GetIndexFromObj(NULL, objv[2], ddeEvalOptions, "option", - 0, &argIndex) == TCL_OK) { + if (Tcl_GetIndexFromObjStruct(NULL, objv[2], ddeEvalOptions, + sizeof(char *), "option", 0, &argIndex) == TCL_OK) { if (objc < 5) { goto wrongDdeEvalArgs; } @@ -1736,21 +1750,26 @@ DdeObjCmd( } if (interp != sendInterp) { if (result == TCL_ERROR) { + Tcl_Obj *varName; /* * An error occurred, so transfer error information from * the destination interpreter back to our interpreter. */ Tcl_ResetResult(interp); - objPtr = Tcl_GetVar2Ex(sendInterp, "errorInfo", NULL, + varName = Tcl_NewStringObj("errorInfo", -1); + Tcl_IncrRefCount(varName); + objPtr = Tcl_ObjGetVar2(sendInterp, varName, NULL, TCL_GLOBAL_ONLY); + Tcl_DecrRefCount(varName); if (objPtr) { - string = Tcl_GetStringFromObj(objPtr, &length); - Tcl_AddObjErrorInfo(interp, string, length); + Tcl_AppendObjToErrorInfo(interp, objPtr); } - - objPtr = Tcl_GetVar2Ex(sendInterp, "errorCode", NULL, + varName = Tcl_NewStringObj("errorCode", -1); + Tcl_IncrRefCount(varName); + objPtr = Tcl_ObjGetVar2(sendInterp, varName, NULL, TCL_GLOBAL_ONLY); + Tcl_DecrRefCount(varName); if (objPtr) { Tcl_SetObjErrorCode(interp, objPtr); } @@ -1841,9 +1860,7 @@ DdeObjCmd( Tcl_DecrRefCount(resultPtr); goto invalidServerResponse; } - length = -1; - string = Tcl_GetStringFromObj(objPtr, &length); - Tcl_AddObjErrorInfo(interp, string, length); + Tcl_AppendObjToErrorInfo(interp, objPtr); Tcl_ListObjIndex(NULL, resultPtr, 2, &objPtr); Tcl_SetObjErrorCode(interp, objPtr); diff --git a/win/tclWinFCmd.c b/win/tclWinFCmd.c index ac88861..db5ed9e 100644 --- a/win/tclWinFCmd.c +++ b/win/tclWinFCmd.c @@ -1607,7 +1607,7 @@ GetWinFileAttributes( } } - *attributePtrPtr = Tcl_NewBooleanObj(attr); + *attributePtrPtr = Tcl_NewLongObj(attr!=0); return TCL_OK; } diff --git a/win/tclWinFile.c b/win/tclWinFile.c index a1189f5..18b05d6 100644 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -15,7 +15,6 @@ #include "tclWinInt.h" #include "tclFileSystem.h" #include <winioctl.h> -#include <sys/stat.h> #include <shlobj.h> #include <lm.h> /* For TclpGetUserHome(). */ @@ -160,7 +159,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 +443,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 +541,7 @@ WinReadLinkDirectory( if (!(attr & FILE_ATTRIBUTE_REPARSE_POINT)) { goto invalidError; } - if (NativeReadReparse(linkDirPath, reparseBuffer)) { + if (NativeReadReparse(linkDirPath, reparseBuffer, 0)) { return NULL; } @@ -663,12 +662,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) { @@ -2475,6 +2475,12 @@ TclpObjNormalizePath( } Tcl_DStringAppend(&dsNorm, nativePath, len); lastValidPathEnd = currentPathEndPosition; + } else if (nextCheckpoint == 0) { + /* Path starts with a drive designation + * that's not actually on the system. + * We still must normalize up past the + * first separator. [Bug 3603434] */ + currentPathEndPosition++; } } Tcl_DStringFree(&ds); @@ -2615,6 +2621,12 @@ TclpObjNormalizePath( (const char *)nativePath, (int)(sizeof(WCHAR) * len)); lastValidPathEnd = currentPathEndPosition; + } else if (nextCheckpoint == 0) { + /* Path starts with a drive designation + * that's not actually on the system. + * We still must normalize up past the + * first separator. [Bug 3603434] */ + currentPathEndPosition++; } } Tcl_DStringFree(&ds); diff --git a/win/tclWinNotify.c b/win/tclWinNotify.c index 4543b02..aaa5878 100644 --- a/win/tclWinNotify.c +++ b/win/tclWinNotify.c @@ -27,7 +27,7 @@ * created for each thread that is using the notifier. */ -typedef struct ThreadSpecificData { +typedef struct { CRITICAL_SECTION crit; /* Monitor for this notifier. */ DWORD thread; /* Identifier for thread associated with this * notifier. */ diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c index 36ae58a..f7ceabc 100644 --- a/win/tclWinPipe.c +++ b/win/tclWinPipe.c @@ -12,8 +12,6 @@ #include "tclWinInt.h" -#include <sys/stat.h> - /* * The following variable is used to tell whether this module has been * initialized. @@ -52,7 +50,7 @@ TCL_DECLARE_MUTEX(pipeMutex) * used in a pipeline. */ -typedef struct WinFile { +typedef struct { int type; /* One of the file types defined above. */ HANDLE handle; /* Open file handle. */ } WinFile; @@ -144,7 +142,7 @@ typedef struct PipeInfo { * synchronized with the readable object. */ } PipeInfo; -typedef struct ThreadSpecificData { +typedef struct { /* * The following pointer refers to the head of the list of pipes that are * being watched for file events. @@ -160,7 +158,7 @@ static Tcl_ThreadDataKey dataKey; * events are generated. */ -typedef struct PipeEvent { +typedef struct { Tcl_Event header; /* Information that is standard for all * events. */ PipeInfo *infoPtr; /* Pointer to pipe info structure. Note that diff --git a/win/tclWinReg.c b/win/tclWinReg.c index 619d9df..372096e 100644 --- a/win/tclWinReg.c +++ b/win/tclWinReg.c @@ -13,9 +13,9 @@ */ #undef STATIC_BUILD -#undef USE_TCL_STUBS -#define USE_TCL_STUBS - +#ifndef USE_TCL_STUBS +# define USE_TCL_STUBS +#endif #include "tclInt.h" #ifdef _MSC_VER # pragma comment (lib, "advapi32.lib") @@ -156,14 +156,14 @@ Registry_Init( { Tcl_Command cmd; - if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) { + if (Tcl_InitStubs(interp, "8.5", 0) == NULL) { return TCL_ERROR; } cmd = Tcl_CreateObjCommand(interp, "registry", RegistryObjCmd, interp, DeleteCmd); Tcl_SetAssocData(interp, REGISTRY_ASSOC_KEY, NULL, cmd); - return Tcl_PkgProvide(interp, "registry", "1.3.0"); + return Tcl_PkgProvideEx(interp, "registry", "1.3.0", NULL); } /* @@ -281,9 +281,9 @@ RegistryObjCmd( return TCL_ERROR; } - if (Tcl_GetString(objv[n])[0] == '-') { - if (Tcl_GetIndexFromObj(interp, objv[n++], modes, "mode", 0, - &index) != TCL_OK) { + if (Tcl_GetStringFromObj(objv[n], NULL)[0] == '-') { + if (Tcl_GetIndexFromObjStruct(interp, objv[n++], modes, + sizeof(char *), "mode", 0, &index) != TCL_OK) { return TCL_ERROR; } switch (index) { @@ -299,8 +299,8 @@ RegistryObjCmd( } } - if (Tcl_GetIndexFromObj(interp, objv[n++], subcommands, "option", 0, - &index) != TCL_OK) { + if (Tcl_GetIndexFromObjStruct(interp, objv[n++], subcommands, + sizeof(char *), "option", 0, &index) != TCL_OK) { return TCL_ERROR; } @@ -520,7 +520,8 @@ DeleteValue( if (result != ERROR_SUCCESS) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unable to delete value \"%s\" from key \"%s\": ", - Tcl_GetString(valueNameObj), Tcl_GetString(keyNameObj))); + Tcl_GetStringFromObj(valueNameObj, NULL), + Tcl_GetStringFromObj(keyNameObj, NULL))); AppendSystemError(interp, result); result = TCL_ERROR; } else { @@ -568,7 +569,7 @@ GetKeyNames( Tcl_DString ds; /* Buffer to translate subkey name to UTF-8 */ if (patternObj) { - pattern = Tcl_GetString(patternObj); + pattern = Tcl_GetStringFromObj(patternObj, NULL); } else { pattern = NULL; } @@ -597,7 +598,7 @@ GetKeyNames( } else { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unable to enumerate subkeys of \"%s\": ", - Tcl_GetString(keyNameObj))); + Tcl_GetStringFromObj(keyNameObj, NULL))); AppendSystemError(interp, result); result = TCL_ERROR; } @@ -680,7 +681,8 @@ GetType( if (result != ERROR_SUCCESS) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unable to get type of value \"%s\" from key \"%s\": ", - Tcl_GetString(valueNameObj), Tcl_GetString(keyNameObj))); + Tcl_GetStringFromObj(valueNameObj, NULL), + Tcl_GetStringFromObj(keyNameObj, NULL))); AppendSystemError(interp, result); return TCL_ERROR; } @@ -691,7 +693,7 @@ GetType( */ if (type > lastType) { - Tcl_SetObjResult(interp, Tcl_NewIntObj((int) type)); + Tcl_SetObjResult(interp, Tcl_NewLongObj((int) type)); } else { Tcl_SetObjResult(interp, Tcl_NewStringObj(typeNames[type], -1)); } @@ -774,7 +776,8 @@ GetValue( if (result != ERROR_SUCCESS) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unable to get value \"%s\" from key \"%s\": ", - Tcl_GetString(valueNameObj), Tcl_GetString(keyNameObj))); + Tcl_GetStringFromObj(valueNameObj, NULL), + Tcl_GetStringFromObj(keyNameObj, NULL))); AppendSystemError(interp, result); Tcl_DStringFree(&data); return TCL_ERROR; @@ -788,7 +791,7 @@ GetValue( */ if (type == REG_DWORD || type == REG_DWORD_BIG_ENDIAN) { - Tcl_SetObjResult(interp, Tcl_NewIntObj((int) ConvertDWORD(type, + Tcl_SetObjResult(interp, Tcl_NewLongObj((long) ConvertDWORD(type, *((DWORD *) Tcl_DStringValue(&data))))); } else if (type == REG_MULTI_SZ) { char *p = Tcl_DStringValue(&data); @@ -878,7 +881,7 @@ GetValueNames( result = TCL_OK; if (patternObj) { - pattern = Tcl_GetString(patternObj); + pattern = Tcl_GetStringFromObj(patternObj, NULL); } else { pattern = NULL; } @@ -1118,8 +1121,8 @@ ParseKeyName( */ rootObj = Tcl_NewStringObj(rootName, -1); - result = Tcl_GetIndexFromObj(interp, rootObj, rootKeyNames, "root name", - TCL_EXACT, &index); + result = Tcl_GetIndexFromObjStruct(interp, rootObj, rootKeyNames, + sizeof(char *), "root name", TCL_EXACT, &index); Tcl_DecrRefCount(rootObj); if (result != TCL_OK) { return TCL_ERROR; @@ -1254,8 +1257,8 @@ SetValue( if (typeObj == NULL) { type = REG_SZ; - } else if (Tcl_GetIndexFromObj(interp, typeObj, typeNames, "type", - 0, (int *) &type) != TCL_OK) { + } else if (Tcl_GetIndexFromObjStruct(interp, typeObj, typeNames, + sizeof(char *), "type", 0, (int *) &type) != TCL_OK) { if (Tcl_GetIntFromObj(NULL, typeObj, (int *) &type) != TCL_OK) { return TCL_ERROR; } @@ -1408,7 +1411,7 @@ BroadcastValue( * Use the ignore the result. */ - result = SendMessageTimeoutA(HWND_BROADCAST, WM_SETTINGCHANGE, + result = SendMessageTimeout(HWND_BROADCAST, WM_SETTINGCHANGE, (WPARAM) 0, (LPARAM) str, SMTO_ABORTIFHUNG, timeout, &sendResult); objPtr = Tcl_NewObj(); diff --git a/win/tclWinSerial.c b/win/tclWinSerial.c index 458b05b..9961b01 100644 --- a/win/tclWinSerial.c +++ b/win/tclWinSerial.c @@ -14,8 +14,6 @@ #include "tclWinInt.h" -#include <sys/stat.h> - /* * The following variable is used to tell whether this module has been * initialized. @@ -122,7 +120,7 @@ typedef struct SerialInfo { * [fconfigure -queue] */ } SerialInfo; -typedef struct ThreadSpecificData { +typedef struct { /* * The following pointer refers to the head of the list of serials that * are being watched for file events. @@ -138,7 +136,7 @@ static Tcl_ThreadDataKey dataKey; * events are generated. */ -typedef struct SerialEvent { +typedef struct { Tcl_Event header; /* Information that is standard for all * events. */ SerialInfo *infoPtr; /* Pointer to serial info structure. Note that diff --git a/win/tclWinTest.c b/win/tclWinTest.c index 136c4db..17b76b8 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 } @@ -277,11 +277,11 @@ TestwinclockCmd( result = Tcl_NewObj(); Tcl_ListObjAppendElement(interp, result, - Tcl_NewIntObj((int) (t2.QuadPart / 10000000))); + Tcl_NewLongObj((int) (t2.QuadPart / 10000000))); Tcl_ListObjAppendElement(interp, result, - Tcl_NewIntObj((int) ((t2.QuadPart / 10) % 1000000))); - Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj(tclTime.sec)); - Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj(tclTime.usec)); + Tcl_NewLongObj((int) ((t2.QuadPart / 10) % 1000000))); + Tcl_ListObjAppendElement(interp, result, Tcl_NewLongObj(tclTime.sec)); + Tcl_ListObjAppendElement(interp, result, Tcl_NewLongObj(tclTime.usec)); Tcl_ListObjAppendElement(interp, result, Tcl_NewWideIntObj(p1.QuadPart)); Tcl_ListObjAppendElement(interp, result, Tcl_NewWideIntObj(p2.QuadPart)); @@ -368,8 +368,8 @@ TestExceptionCmd( Tcl_WrongNumArgs(interp, 0, objv, "<type-of-exception>"); return TCL_ERROR; } - if (Tcl_GetIndexFromObj(interp, objv[1], cmds, "command", 0, - &cmd) != TCL_OK) { + if (Tcl_GetIndexFromObjStruct(interp, objv[1], cmds, + sizeof(char *), "command", 0, &cmd) != TCL_OK) { return TCL_ERROR; } diff --git a/win/tclWinThrd.c b/win/tclWinThrd.c index 7b0f6f8..6c4ed7f 100644 --- a/win/tclWinThrd.c +++ b/win/tclWinThrd.c @@ -13,9 +13,6 @@ #include "tclWinInt.h" -#include <float.h> -#include <sys/stat.h> - /* Workaround for mingw versions which don't provide this in float.h */ #ifndef _MCW_EM # define _MCW_EM 0x0008001F /* Error masks */ @@ -111,7 +108,7 @@ static Tcl_ThreadDataKey dataKey; * the queue. */ -typedef struct WinCondition { +typedef struct { CRITICAL_SECTION condLock; /* Lock to serialize queuing on the * condition. */ struct ThreadSpecificData *firstPtr; /* Queue pointers */ @@ -126,7 +123,7 @@ typedef struct WinCondition { static int once; static DWORD tlsKey; -typedef struct allocMutex { +typedef struct { Tcl_Mutex tlock; CRITICAL_SECTION wlock; } allocMutex; @@ -948,9 +945,9 @@ TclpFinalizeCondition( Tcl_Mutex * TclpNewAllocMutex(void) { - struct allocMutex *lockPtr; + allocMutex *lockPtr; - lockPtr = malloc(sizeof(struct allocMutex)); + lockPtr = malloc(sizeof(allocMutex)); if (lockPtr == NULL) { Tcl_Panic("could not allocate lock"); } diff --git a/win/tclWinTime.c b/win/tclWinTime.c index 9cfbac0..d69070b 100644 --- a/win/tclWinTime.c +++ b/win/tclWinTime.c @@ -22,7 +22,7 @@ * Data for managing high-resolution timers. */ -typedef struct TimeInfo { +typedef struct { CRITICAL_SECTION cs; /* Mutex guarding this structure. */ int initialized; /* Flag == 1 if this structure is * initialized. */ 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 |