diff options
188 files changed, 15051 insertions, 10266 deletions
@@ -1,6 +1,6 @@ <?xml version="1.0" encoding="UTF-8"?> <projectDescription> - <name>tcl9.0</name> + <name>tcl9.1</name> <comment></comment> <projects> </projects> @@ -1,6 +1,6 @@ # README: Tcl -This is the **Tcl 9.0.3** source distribution. +This is the **Tcl 9.1a1** source distribution. You can get any source release of Tcl from [our distribution site](https://sourceforge.net/projects/tcl/files/Tcl/). @@ -51,7 +51,7 @@ and selling it either in whole or in part. See the file ## <a id="doc">2.</a> Documentation Extensive documentation is available on our website. The home page for this release, including new features, is -[here](https://www.tcl-lang.org/software/tcltk/9.0.html). +[here](https://www.tcl-lang.org/software/tcltk/9.1.html). Detailed release notes can be found at the [file distributions page](https://sourceforge.net/projects/tcl/files/Tcl/) by clicking on the relevant version. @@ -61,8 +61,8 @@ Xchange](https://www.tcl-lang.org/about/). There have been many Tcl books on the market. Many are mentioned in [the Wiki](https://wiki.tcl-lang.org/_/ref?N=25206). -The complete set of reference manual entries for Tcl 9.0 is [online, -here](https://www.tcl-lang.org/man/tcl9.0/). +The complete set of reference manual entries for Tcl 9.1 is [online, +here](https://www.tcl-lang.org/man/tcl9.1/). ### <a id="doc.unix">2a.</a> Unix Documentation The `doc` subdirectory in this release contains a complete set of @@ -4,245 +4,28 @@ changes to the Tcl source code at > [Tcl Source Code](https://core.tcl-lang.org/tcl/timeline) -Release Tcl 9.0.3 arises from the check-in with tag `core-9-0-3`. +Release Tcl 9.1a1 arises from the check-in with tag `core-9-1-a1`. -Tcl patch releases have the primary purpose of delivering bug fixes -to the userbase. - -# Bug fixes - - [On Unix, IsTimeNative() always defined but not always used](https://core.tcl-lang.org/tcl/tktview/6b8e39) - - [Tweak install permissions](https://core.tcl-lang.org/tcl/tktview/31d4fa) - -# Updated bundled packages, libraries, standards, data - - platform 1.1.0 - - sqlite3 3.50.4 - - tcltest 2.5.10 - - Thread 3.0.3 - - TDBC\* 1.1.12 - -Release Tcl 9.0.2 arises from the check-in with tag `core-9-0-2`. - -Tcl patch releases have the primary purpose of delivering bug fixes -to the userbase. - -# New commands and options - - [New command encoding user](https://core.tcl-lang.org/tips/doc/trunk/tip/716.md) - - [New exec option -encoding](https://core.tcl-lang.org/tips/doc/trunk/tip/716.md) - -# Bug fixes - - [Better error-message than "interpreter uses an incompatible stubs mechanism"](https://core.tcl-lang.org/tcl/tktview/fc3509) - - [\[$interp eval $lambda\] after \[eval $lambda\] or vice versa fails](https://core.tcl-lang.org/tcl/tktview/67d5f7) - - [tcl::mathfunc::isunordered inconsistency with some integer values](https://core.tcl-lang.org/tcl/tktview/98006f) - - [test lseq hangs with -Os](https://core.tcl-lang.org/tcl/tktview/d2a3c5) - - [exec does not handle app execution aliases on Windows](https://core.tcl-lang.org/tcl/tktview/4f0b57) - - [auto_execok does not find several built-in cmd commands](https://core.tcl-lang.org/tcl/tktview/4e2c8b) - - [Panic "Buffer Underflow, BUFFER_PADDING not enough"](https://core.tcl-lang.org/tcl/tktview/73bb42) - - [MS-VS build system: pckIndex.tcl when building for 9 misses "t" for TCL 8.6 part](https://core.tcl-lang.org/tcl/tktview/a77029) - - [clock format -locale does not look up locale children if parent locale used first](https://core.tcl-lang.org/tcl/tktview/2c0f49) - - [Missing libtcl?.?.dll.a in Cygwin](https://core.tcl-lang.org/tcl/tktview/dcedba) - - [tclEpollNotfy PlatformEventsControl panics if websocket disconnected](https://core.tcl-lang.org/tcl/tktview/010d8f) - - [Tcl_InitStubs compatibility for 9.1](https://core.tcl-lang.org/tcl/tktview/fd8341) - - [proc with more than 2**31 variables](https://core.tcl-lang.org/tcl/tktview/92aeb8) - - [scan "long mantissa" %g](https://core.tcl-lang.org/tcl/tktview/42d14c) - - ["encoding system": wrong result without manifest](https://core.tcl-lang.org/tcl/tktview/8ffd8c) - - [lseq crash on out-of-range index](https://core.tcl-lang.org/tcl/tktview/7d3101) - - [lseq crash on nested indices](https://core.tcl-lang.org/tcl/tktview/452b10) - - [Build broken (trunk branch) tclCompExpr.c tclOOCall.c](https://core.tcl-lang.org/tcl/tktview/1dcda0) - - [Memory allocation runaway on truncated iso2022 encoding](https://core.tcl-lang.org/tcl/tktview/7346ad) - - [Missing include dir for extensions in non-default locations](https://core.tcl-lang.org/tcl/tktview/333512) - - [tcl::tm::path doesn't handle tilde expand](https://core.tcl-lang.org/tcl/tktview/b87673) - - [lseq numeric overflow](https://core.tcl-lang.org/tcl/tktview/0ee626) - - ["return": broken ordering of nested -options](https://core.tcl-lang.org/tcl/tktview/ecf35c) - - [Euro/Tail-sign missing from cp864 encoding](https://core.tcl-lang.org/tcl/tktview/ecafd8) - - [use after free on TSD in Winsock](https://core.tcl-lang.org/tcl/tktview/40b181) - - [use after free on Windows pipe handles](https://core.tcl-lang.org/tcl/tktview/7c2716) - - [tcl::build-info not documented](https://core.tcl-lang.org/tcl/tktview/ef7042) - - [Fix 32 bit overflow in interp limit](https://core.tcl-lang.org/tcl/tktview/9dfae3) - -# Incompatibilities - - [The ActiveCodePage element has been removed from the Windows executable manifest for tclsh](https://core.tcl-lang.org/tips/doc/trunk/tip/716.md) - -# Updated bundled packages, libraries, standards, data - - Itcl 4.3.3 - - sqlite3 3.49.1 - - Thread 3.0.2 - - TDBC\* 1.1.11 - - tzdata 2025b - -Release Tcl 9.0.1 arises from the check-in with tag `core-9-0-1`. - -Tcl patch releases have the primary purpose of delivering bug fixes -to the userbase. As the first patch release in the Tcl 9.0.\* series, -Tcl 9.0.1 also includes a small number of interface changes that complete -some incomplete features first delivered in Tcl 9.0.0. - -# Completed 9.0 Features and Interfaces - - [TIP 701 - Tcl_FSTildeExpand C API](https://core.tcl-lang.org/tips/doc/trunk/tip/701.md) - - [TIP 707 - ptrAndSize internal rep in Tcl_Obj](https://core.tcl-lang.org/tips/doc/trunk/tip/707.md) - - [Size modifiers j, q, z, t not implemented]( https://core.tcl-lang.org/tcl/info/c4f365) - -# Bug fixes - - [regression in tzdata, %z instead of offset TZ-name](https://core.tcl-lang.org/tcl/tktview/2c237b) - - [Tcl will not start properly if there is an init.tcl file in the current dir](https://core.tcl-lang.org/tcl/tktview/43c94f) - - [clock scan "24:00", ISO-8601 compatibility](https://core.tcl-lang.org/tcl/tktview/aee9f2) - - [Temporary folder with file "tcl9registry13.dll" remains after "exit"](https://core.tcl-lang.org/tcl/tktview/6ce3c0) - - [Wrong result by "lsearch -stride -subindices -inline -all"](https://core.tcl-lang.org/tcl/info/5a1aaa) - - [TIP 609 - required Tcl_ThreadAlert() skipped with nested event loop](https://core.tcl-lang.org/tcl/info/c7e4c4) - - [buffer overwrite for non-BMP characters in utf-16](https://core.tcl-lang.org/tcl/tktview/66da4d) - - [zipfs info on mountpoint of executable returns zero offset in field 4"](https://core.tcl-lang.org/tcl/info/aaa84f) - - [zlib-8.8, zlib-8.16 fail on Fedora 40, gcc 14.1.1](https://core.tcl-lang.org/tcl/tktview/73d5cb) - - [install registry and dde in $INSTALL_DIR\lib always](https://core.tcl-lang.org/tcl/tktview/364bd9) - - [cannot build .chm help file (Windows)](https://core.tcl-lang.org/tcl/tktview/bb110c) - -# Incompatibilities - - No known incompatibilities with the Tcl 9.0.0 public interface. - -# Updated bundled packages, libraries, standards, data - - Itcl 4.3.2 - - sqlite3 3.47.2 - - Thread 3.0.1 - - TDBC\* 1.1.10 - - tcltest 2.5.9 - - tzdata 2024b, corrected - -Release Tcl 9.0.0 arises from the check-in with tag `core-9-0-0`. - -Highlighted differences between Tcl 9.0 and Tcl 8.6 are summarized below, +Highlighted differences between Tcl 9.1 and Tcl 9.0 are summarized below, with focus on changes important to programmers using the Tcl library and writing Tcl scripts. -# Major Features - -## 64-bit capacity: Data values larger than 2Gb - - Strings can be any length (that fits in your available memory) - - Lists and dictionaries can have very large numbers of elements - -## Internationalization of text - - Full Unicode range of codepoints - - New encodings: `utf-16`/`utf-32`/`ucs-2`(`le`|`be`), `CESU-8`, etc. - - `encoding` options `-profile`, `-failindex` manage encoding of I/O. - - `msgcat` supports custom locale search list - - `source` defaults to `-encoding utf-8` - -## Zip filesystems and attached archives. - - Packaging of the Tcl script library with the Tcl binary library, - meaning that the `TCL_LIBRARY` environment variable is usually not required. - - Packaging of an application into a virtual filesystem is now a supported - core Tcl feature. - -## Unix notifiers available using `epoll()` or `kqueue()` - - This relieves limits on file descriptors imposed by legacy `select()` and fixes a performance bottleneck. - -# Incompatibilities - -## Notable incompatibilities - - Unqualified varnames resolved in current namespace, not global. - Note that in almost all cases where this causes a change, the change is actually the removal of a latent bug. - - No `--disable-threads` build option. Always thread-enabled. - - I/O malencoding default response: raise error (`-profile strict`) - - Windows platform needs Windows 7 or Windows Server 2008 R2 or later - - Ended interpretation of `~` as home directory in pathnames. - (See `file home` and `file tildeexpand` for replacements when you need them.) - - Removed the `identity` encoding. - (There were only ever very few valid use cases for this; almost all uses - were systematically wrong.) - - Removed the encoding alias `binary` to `iso8859-1`. - - `$::tcl_precision` no longer controls string generation of doubles. - (If you need a particular precision, use `format`.) - - Removed pre-Tcl 8 legacies: `case`, `puts` and `read` variant syntaxes. - - Removed subcommands [`trace variable`|`vdelete`|`vinfo`] - - Removed `-eofchar` option for write channels. - - On Windows 10+ (Version 1903 or higher), system encoding is always utf-8. - - `%b`/`%d`/`%o`/`%x` format modifiers (without size modifier) for `format` - and `scan` always truncate to 32-bits on all platforms. - - `%L` size modifier for `scan` no longer truncates to 64-bit. - - Removed command `::tcl::unsupported::inject`. - (See `coroinject` and `coroprobe` for supported commands with significantly - more comprehensible semantics.) - -## Incompatibilities in C public interface - - Extensions built against Tcl 8.6 and before will not work with Tcl 9.0; - ABI compatibility was a non-goal for 9.0. In _most_ cases, rebuilding - against Tcl 9.0 should work except when a removed API function is used. - - Many arguments expanded type from `int` to `Tcl_Size`, a signed integer type - large enough to support 64-bit sized memory objects. - The constant `TCL_AUTO_LENGTH` is a value of that type that indicates that - the length should be obtained using an appropriate function (typically `strlen()` for `char *` values). - - Ended support for `Tcl_ChannelTypeVersion` less than 5 - - Introduced versioning of the `Tcl_ObjType` struct - - Removed macros `CONST*`: Tcl 9 support means dropping Tcl 8.3 support. - (Replaced with standard C `const` keyword going forward.) - - Removed registration of several `Tcl_ObjType`s. - - Removed API functions: - - `Tcl_Backslash()`, - `Tcl_*VA()`, - `Tcl_*MathFunc*()`, - `Tcl_MakeSafe()`, - `Tcl_(Save|Restore|Discard|Free)Result()`, - `Tcl_EvalTokens()`, - `Tcl_(Get|Set)DefaultEncodingDir()`, - `Tcl_UniCharN(case)cmp()`, - `Tcl_UniCharCaseMatch()` - - - Revised many internals; beware reliance on undocumented behaviors. +# New commands and options -# New Features +- [New options -backslashes, -commands and -variables for subst command](https://core.tcl-lang.org/tips/doc/trunk/tip/712.md) -## New commands - - `array default` — Specify default values for arrays (note that this alters the behaviour of `append`, `incr`, `lappend`). - - `array for` — Cheap iteration over an array's contents. - - `chan isbinary` — Test if a channel is configured to work with binary data. - - `coroinject`, `coroprobe` — Interact with paused coroutines. - - `clock add weekdays` — Clock arithmetic with week days. - - `const`, `info const*` — Commands for defining constants (variables that can't be modified). - - `dict getwithdefault` — Define a fallback value to use when `dict get` would otherwise fail. - - `file home` — Get the user home directory. - - `file tempdir` — Create a temporary directory. - - `file tildeexpand` — Expand a file path containing a `~`. - - `info commandtype` — Introspection for the kinds of commands. - - `ledit` — Equivalent to `lreplace` but on a list in a variable. - - `lpop` — Remove an item from a list in a variable. - - `lremove` — Remove a sublist from a list in a variable. - - `lseq` — Generate a list of numbers in a sequence. - - `package files` — Describe the contents of a package. - - `string insert` — Insert a string as a substring of another string. - - `string is dict` — Test whether a string is a dictionary. - - `tcl::process` — Commands for working with subprocesses. - - `*::build-info` — Obtain information about the build of Tcl. - - `readFile`, `writeFile`, `foreachLine` — Simple procedures for basic working with files. - - `tcl::idna::*` — Commands for working with encoded DNS names. +# New public C API -## New command options - - `chan configure ... -inputmode ...` — Support for raw terminal input and reading passwords. - - `clock scan ... -validate ...` - - `info loaded ... ?prefix?` - - `lsearch ... -stride ...` — Search a list by groups of items. - - `regsub ... -command ...` — Generate the replacement for a regular expression by calling a command. - - `socket ... -nodelay ... -keepalive ...` - - `vwait` controlled by several new options - - `expr` string comparators `lt`, `gt`, `le`, `ge` - - `expr` supports comments inside expressions +- [Tcl\_IsEmpty checks if the string representation of a value would be the empty string](https://core.tcl-lang.org/tips/doc/trunk/tip/711.md) +- [Tcl\_GetEncodingNameForUser returns name of encoding from user settings](https://core.tcl-lang.org/tips/doc/trunk/tip/716.md) +- [Tcl\_AttemptCreateHashEntry - version of Tcl\_CreateHashEntry that returns NULL instead of panic'ing on memory allocation errors](https://core.tcl-lang.org/tips/doc/trunk/tip/717.md) +- [Tcl\_ListObjRange, Tcl\_ListObjRepeat, Tcl\_TclListObjReverse - C API for new list operations](https://core.tcl-lang.org/tips/doc/trunk/tip/649.md) -## Numbers - - <code>0<i>NNN</i></code> format is no longer octal interpretation. Use <code>0o<i>NNN</i></code>. - - <code>0d<i>NNNN</i></code> format to compel decimal interpretation. - - <code>NN_NNN_NNN</code>, underscores in numbers for optional readability - - Functions: `isinf()`, `isnan()`, `isnormal()`, `issubnormal()`, `isunordered()` - - Command: `fpclassify` - - Function `int()` no longer truncates to word size +# Performance -## TclOO facilities - - private variables and methods - - class variables and methods - - abstract and singleton classes - - configurable properties - - `method -export`, `method -unexport` +- [Memory efficient internal representations](https://core.tcl-lang.org/tcl/wiki?name=New+abstract+list+representations) +for list operations on large lists. -# Known bugs - - [changed behaviour wrt command names, namespaces and resolution](https://core.tcl-lang.org/tcl/tktview/f14b33) - - [windows dos device paths inconsistencies and missing functionality](https://core.tcl-lang.org/tcl/tktview/d8f121) - - [load library (dll) from zipfs-library causes a leak in temporary folder](https://core.tcl-lang.org/tcl/tktview/a8e4f7) - - [lsearch -sorted -inline -subindices incorrect result](https://core.tcl-lang.org/tcl/tktview/bc4ac0) - - ["No error" when load fails due to a missing secondary DLL](https://core.tcl-lang.org/tcl/tktview/66aa81c90a) +# Bug fixes + - [tclEpollNotfy PlatformEventsControl panics if websocket disconnected](https://core.tcl-lang.org/tcl/tktview/010d8f38) diff --git a/doc/Encoding.3 b/doc/Encoding.3 index 45398f3..305edbb 100644 --- a/doc/Encoding.3 +++ b/doc/Encoding.3 @@ -8,7 +8,7 @@ .so man.macros .BS .SH NAME -Tcl_GetEncoding, Tcl_FreeEncoding, Tcl_GetEncodingFromObj, Tcl_ExternalToUtfDString, Tcl_ExternalToUtfDStringEx, Tcl_ExternalToUtf, Tcl_UtfToExternalDString, Tcl_UtfToExternalDStringEx, Tcl_UtfToExternal, Tcl_GetEncodingName, Tcl_SetSystemEncoding, Tcl_GetEncodingNameFromEnvironment, Tcl_GetEncodingNames, Tcl_CreateEncoding, Tcl_GetEncodingSearchPath, Tcl_SetEncodingSearchPath \- procedures for creating and using encodings +Tcl_GetEncoding, Tcl_FreeEncoding, Tcl_GetEncodingFromObj, Tcl_ExternalToUtfDString, Tcl_ExternalToUtfDStringEx, Tcl_ExternalToUtf, Tcl_UtfToExternalDString, Tcl_UtfToExternalDStringEx, Tcl_UtfToExternal, Tcl_GetEncodingName, Tcl_SetSystemEncoding, Tcl_GetEncodingNameFromEnvironment, Tcl_GetEncodingNameForUser, Tcl_GetEncodingNames, Tcl_CreateEncoding, Tcl_GetEncodingSearchPath, Tcl_SetEncodingSearchPath \- procedures for creating and using encodings .SH SYNOPSIS .nf \fB#include <tcl.h>\fR @@ -53,6 +53,9 @@ int const char * \fBTcl_GetEncodingNameFromEnvironment\fR(\fIbufPtr\fR) .sp +const char * +\fBTcl_GetEncodingNameForUser\fR(\fIbufPtr\fR) +.sp \fBTcl_GetEncodingNames\fR(\fIinterp\fR) .sp Tcl_Encoding @@ -308,12 +311,22 @@ procedure increments the reference count of the new system encoding, decrements the reference count of the old system encoding, and returns \fBTCL_OK\fR. .PP -\fBTcl_GetEncodingNameFromEnvironment\fR provides a means for the Tcl -library to report the encoding name it believes to be the correct one -to use as the system encoding, based on system calls and examination of -the environment suitable for the platform. It accepts \fIbufPtr\fR, -a pointer to an uninitialized or freed \fBTcl_DString\fR and writes -the encoding name to it. The \fBTcl_DStringValue\fR is returned. +\fBTcl_GetEncodingNameFromEnvironment\fR retrieves the encoding name to +use as the system encoding. On non-Windows platforms, this is derived +from the \fBnl_langinfo\fR system call if available, and environment +variables \fBLC_ALL\fR, \fBLC_CTYPE\fR or \fBLANG\fR otherwise. On +Windows versions Windows 10 Build 18362 and later the returned value is +always \fButf-8\fR. On earlier Windows versions, it is derived from the +user settings in the Windows registry. \fBTcl_GetEncodingNameForUser\fR +retrieves the encoding name based on the user settings for the current +user and is derived in the same manner as +\fBTcl_GetEncodingNameFromEnvironment\fR on non-Windows platforms. On +Windows, unlike \fBTcl_GetEncodingNameFromEnvironment\fR, it returns the +encoding name as per the Windows registry settings irrespective of the +Windows version. Both functions accept \fIbufPtr\fR, a pointer to an +uninitialized or freed \fBTcl_DString\fR and write the encoding name to +it. They return \fBTcl_DStringValue(bufPtr)\fR which points to the stored +name. .PP \fBTcl_GetEncodingNames\fR sets the \fIinterp\fR result to a list consisting of the names of all the encodings that are currently defined @@ -9,7 +9,7 @@ .so man.macros .BS .SH NAME -Tcl_InitHashTable, Tcl_InitCustomHashTable, Tcl_InitObjHashTable, Tcl_DeleteHashTable, Tcl_CreateHashEntry, Tcl_DeleteHashEntry, Tcl_FindHashEntry, Tcl_GetHashValue, Tcl_SetHashValue, Tcl_GetHashKey, Tcl_FirstHashEntry, Tcl_NextHashEntry, Tcl_HashStats \- procedures to manage hash tables +Tcl_InitHashTable, Tcl_InitCustomHashTable, Tcl_InitObjHashTable, Tcl_DeleteHashTable, Tcl_CreateHashEntry, Tcl_AttemptCreateHashEntry, Tcl_DeleteHashEntry, Tcl_FindHashEntry, Tcl_GetHashValue, Tcl_SetHashValue, Tcl_GetHashKey, Tcl_FirstHashEntry, Tcl_NextHashEntry, Tcl_HashStats \- procedures to manage hash tables .SH SYNOPSIS .nf \fB#include <tcl.h>\fR @@ -25,6 +25,9 @@ Tcl_InitHashTable, Tcl_InitCustomHashTable, Tcl_InitObjHashTable, Tcl_DeleteHash Tcl_HashEntry * \fBTcl_CreateHashEntry\fR(\fItablePtr, key, newPtr\fR) .sp +Tcl_HashEntry * +\fBTcl_AttemptCreateHashEntry\fR(\fItablePtr, key, newPtr\fR) +.sp \fBTcl_DeleteHashEntry\fR(\fIentryPtr\fR) .sp Tcl_HashEntry * @@ -170,10 +173,16 @@ If an entry already existed with the given key then \fI*newPtr\fR is set to zero. If a new entry was created, then \fI*newPtr\fR is set to a non-zero value and the value of the new entry will be set to zero. +\fI*newPtr\fR is allowed to be NULL. The return value from \fBTcl_CreateHashEntry\fR is a pointer to the entry, which may be used to retrieve and modify the entry's value or to delete the entry from the table. .PP +\fBTcl_AttemptCreateHashEntry\fR does the same as +\fBTcl_CreateHashEntry\fR, except in case of a memory +overflow. \fBTcl_AttemptCreateHashEntry\fR returns NULL +in that case while \fBTcl_CreateHashEntry\fR panics. +.PP \fBTcl_DeleteHashEntry\fR will remove an existing entry from a table. The memory associated with the entry itself will be freed, but @@ -276,7 +285,7 @@ The \fIhashKeyProc\fR member contains the address of a function called to calculate a hash value for the key. .PP .CS -typedef TCL_HASH_TYPE \fBTcl_HashKeyProc\fR( +typedef size_t \fBTcl_HashKeyProc\fR( Tcl_HashTable *\fItablePtr\fR, void *\fIkeyPtr\fR); .CE diff --git a/doc/ListObj.3 b/doc/ListObj.3 index 9fd7091..b3b4d93 100644 --- a/doc/ListObj.3 +++ b/doc/ListObj.3 @@ -4,11 +4,11 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -.TH Tcl_ListObj 3 8.0 Tcl "Tcl Library Procedures" +.TH Tcl_ListObj 3 9.1 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME -Tcl_ListObjAppendList, Tcl_ListObjAppendElement, Tcl_NewListObj, Tcl_SetListObj, Tcl_ListObjGetElements, Tcl_ListObjLength, Tcl_ListObjIndex, Tcl_ListObjReplace \- manipulate Tcl values as lists +Tcl_ListObjAppendList, Tcl_ListObjAppendElement, Tcl_NewListObj, Tcl_SetListObj, Tcl_ListObjGetElements, Tcl_ListObjLength, Tcl_ListObjIndex, Tcl_ListObjReplace, Tcl_ListObjRange, Tcl_ListObjRepeat, Tcl_ListObjReverse \- manipulate Tcl values as lists .SH SYNOPSIS .nf \fB#include <tcl.h>\fR @@ -35,6 +35,15 @@ int .sp int \fBTcl_ListObjReplace\fR(\fIinterp, listPtr, first, count, objc, objv\fR) +.sp +int +\fBTcl_ListObjRange\fR(\fIinterp, listPtr, first, last, objPtrPtr\fR) +.sp +int +\fBTcl_ListObjRepeat\fR(\fIinterp, count, objc, objv, objPtrPtr\fR) +.sp +int +\fBTcl_ListObjReverse\fR(\fIinterp, listPtr, objPtrPtr\fR) .fi .SH ARGUMENTS .AS "Tcl_Obj *const" *elemListPtr in/out @@ -43,9 +52,12 @@ If an error occurs while converting a value to be a list value, an error message is left in the interpreter's result value unless \fIinterp\fR is NULL. .AP Tcl_Obj *listPtr in/out -Points to the list value to be manipulated. +Points to the input list value. If \fIlistPtr\fR does not already point to a list value, an attempt will be made to convert it to one. +Some functions may store a reference to it internally so +care must be taken when managing its reference count. +See the \fBREFERENCE COUNT MANAGEMENT\fR section below. .AP Tcl_Obj *elemListPtr in/out For \fBTcl_ListObjAppendList\fR, this points to a list value containing elements to be appended onto \fIlistPtr\fR. @@ -72,16 +84,9 @@ trigger proper error-handling), otherwise expect it to crash. A location where \fBTcl_ListObjGetElements\fR stores a pointer to an array of pointers to the element values of \fIlistPtr\fR. .AP Tcl_Size objc in -The number of Tcl values that \fBTcl_NewListObj\fR -will insert into a new list value, -and \fBTcl_ListObjReplace\fR will insert into \fIlistPtr\fR. -For \fBTcl_SetListObj\fR, -the number of Tcl values to insert into \fIobjPtr\fR. +The number of Tcl values in the \fIobjv\fR array. .AP "Tcl_Obj *const" objv[] in -An array of pointers to values. -\fBTcl_NewListObj\fR will insert these values into a new list value -and \fBTcl_ListObjReplace\fR will insert them into an existing \fIlistPtr\fR. -Each value will become a separate list element. +An array of pointers to Tcl values. .AP "Tcl_Size \&| int" *lengthPtr out Points to location where \fBTcl_ListObjLength\fR stores the length of the list. @@ -95,23 +100,22 @@ Index of the list element that \fBTcl_ListObjIndex\fR is to return. The first element has index 0. .AP Tcl_Obj **objPtrPtr out -Points to place where \fBTcl_ListObjIndex\fR is to store -a pointer to the resulting list element value. +Points to location to store an output list or element value. No assumptions +should be made about the reference count of the returned value. +See the \fBREFERENCE COUNT MANAGEMENT\fR section below. .AP Tcl_Size first in -Index of the starting list element that \fBTcl_ListObjReplace\fR -is to replace. -The list's first element has index 0. +Index of the first element in a range of elements in a list. +.AP Tcl_Size last in +Index of the last element in a range of elements in a list. .AP Tcl_Size count in -The number of elements that \fBTcl_ListObjReplace\fR -is to replace. +The number of elements to be operated on or a repetition count. .BE - .SH DESCRIPTION .PP Tcl list values have an internal representation that supports the efficient indexing and appending. The procedures described in this man page are used to -create, modify, index, and append to Tcl list values from C code. +create, modify, access, and transform Tcl list values from C code. .PP \fBTcl_ListObjAppendList\fR and \fBTcl_ListObjAppendElement\fR both add one or more values @@ -209,7 +213,6 @@ change from Tcl 8 where all list elements always have a reference count of at least 1. (See \fBABSTRACT LIST TYPES\fR, \fBSTORAGE MANAGEMENT OF VALUES\fR, Tcl_BounceRefCount(3), and lseq(n) for more information.) - .PP \fBTcl_ListObjReplace\fR replaces zero or more elements of the list referenced by \fIlistPtr\fR @@ -268,8 +271,44 @@ with a NULL \fIobjvPtr\fR: result = \fBTcl_ListObjReplace\fR(interp, listPtr, first, count, 0, NULL); .CE +.PP +\fBTcl_ListObjRange\fR stores in \fIobjPtrPtr\fR a pointer to a list value +containing all elements in the passed input list \fIlistPtr\fR at indices +between \fIfirst\fR and \fIlast\fR, both inclusive. An empty +list is returned in the case of \fIfirst\fR being greater than \fIlast\fR. +.PP +\fBTcl_ListObjRepeat\fR stores in \fIobjPtrPtr\fR a pointer to a list value +whose elements are the \fIobjc\fR elements passed in \fIobjv\fR, repeated +\fIcount\fR number of times. An error is raised if \fIcount\fR is negative. +.PP +\fBTcl_ListObjReverse\fR stores in \fIobjPtrPtr\fR a pointer to a list value +containing all elements of the input list \fIlistPtr\fR in reverse order. +.PP +For all three functions, \fBTcl_ListObjRange\fR, \fBTcl_ListObjRepeat\fR and +\fBTcl_ListObjReverse\fR, the value passed in \fIlistPtr\fR need not be unshared. +The pointer stored at \fIobjPtrPtr\fR is guaranteed to be different from +\fIlistPtr\fR but no assumptions should be made about its reference count. +In case of errors, the location addressed by \fIobjPtrPtr\fR may have been +modified and should be treated by the caller as undefined. .SH "REFERENCE COUNT MANAGEMENT" .PP +Care must be taken by callers when managing the reference count +of values passed in as well as values returned from the above functions. +.PP +Unless specified otherwise below, the above functions may internally +keep a reference to the value passed in \fIlistPtr\fR and increment its +reference count. Therefore, if \fIlistPtr\fR is newly allocated and has +a zero reference count, it should not be freed after the call with +\fBTcl_DecrRefCount\fR. Rather, use \fBTcl_BounceRefCount\fR instead. +Furthermore, if \fIlistPtr\fR was retrieved from the interpreter result +(e.g. via \fBTcl_GetObjResult\fR) and that is the only reference to the +value, it may be deleted if a function sets the interpreter result on +error. The more general and safe method for passing values is to +increment their reference counts with \fBTcl_IncrRefCount\fR prior to +the call and release them with \fBTcl_DecrRefCount\fR when the call +returns. However, this may preclude certain optimizations based on +modifying unshared values in-place. +.PP \fBTcl_NewListObj\fR always returns a zero-reference object, much like \fBTcl_NewObj\fR. If a non-NULL \fIobjv\fR argument is given, the reference counts of the first \fIobjc\fR values in that array are incremented. @@ -279,20 +318,31 @@ argument, but does require that the object be unshared. The reference counts of the first \fIobjc\fR values in the \fIobjv\fR array are incremented. .PP \fBTcl_ListObjGetElements\fR, \fBTcl_ListObjIndex\fR, and -\fBTcl_ListObjLength\fR do not modify the reference count of their -\fIlistPtr\fR arguments; they only read. Note however that these three -functions may set the interpreter result; if that is the only place that is -holding a reference to the object, it will be deleted. +\fBTcl_ListObjLength\fR do not modify the reference count of the +\fIlistPtr\fR argument except on error when the interpreter +result holds a reference to it as described earlier. .PP \fBTcl_ListObjAppendList\fR, \fBTcl_ListObjAppendElement\fR, and \fBTcl_ListObjReplace\fR require an unshared \fIlistPtr\fR argument. \fBTcl_ListObjAppendList\fR only reads its \fIelemListPtr\fR argument. \fBTcl_ListObjAppendElement\fR increments the reference count of its -\fIobjPtr\fR on success. \fBTcl_ListObjReplace\fR increments the reference -count of the first \fIobjc\fR values in the \fIobjv\fR array on success. Note -however that all these three functions may set the interpreter result on -failure; if that is the only place that is holding a reference to the object, -it will be deleted. +\fIobjPtr\fR on success. \fBTcl_ListObjReplace\fR increments the +reference count of the first \fIobjc\fR values in the \fIobjv\fR array +on success. Note that the same caveat stated earlier applies if the +interpreter result holds a reference to \fIlistPtr\fR. +.PP +The pointer to a result value returned in \fIobjPtrPtr\fR by the +functions \fBTcl_ListObjRange\fR, +\fBTcl_ListObjRepeat\fR and \fBTcl_ListObjReverse\fR is guaranteed +to be different from the \fBlistPtr\fR passed in. It is therefore +safe to manage its reference count independently from that of +\fBlistPtr\fR. No assumptions should be made about its reference +count and the standard reference counting idiom should be followed. +The caller can pass it to a function such as \fBTcl_SetObjResult\fR, +\fBTcl_ListObjAppendElement\fR etc. which take ownership of +its reference count management or dispose of the value itself +with either a \fBTcl_IncrRefCount\fR/\fBTcl_DecrRefCount\fR pair or +\fBTcl_BounceRefCount\fR. .SH "SEE ALSO" Tcl_NewObj(3), Tcl_DecrRefCount(3), Tcl_IncrRefCount(3), Tcl_GetObjResult(3) .SH KEYWORDS diff --git a/doc/ObjectType.3 b/doc/ObjectType.3 index 688a04a..1d9b1ae 100644 --- a/doc/ObjectType.3 +++ b/doc/ObjectType.3 @@ -349,8 +349,9 @@ without converting the value to a List type. This requires the custom type to provide functions that will perform the given operation on the custom data representation. Not all functions are required. In the absence of a particular function (set to NULL), the fallback is to -allow the internal List operation to perform the operation, most -likely causing the value type to be converted to a traditional list. +allow the internal List operation to perform the operation, which +may possibly cause the value type to be converted to a traditional +list. .SS "SCALAR VALUE TYPES" .PP For a custom value type that is scalar or atomic in nature, i.e., not @@ -364,6 +365,17 @@ Version 2, \fBTCL_OBJTYPE_V2\fR, allows full List support when the functions described below are provided. This allows for script level use of the List commands without causing the type of the Tcl_Obj value to be converted to a list. + +Unless specified otherwise, all functions specific to Version 2 should return +\fBTCL_OK\fR on success and \fBTCL_ERROR\fR on failure. + +In the case that a \fBTcl_Obj*\fR is also returned, the reference count of the +returned \fBTcl_Obj\fR should not be incremented so, for example, if a new +\fBTcl_Obj\fR value is returned it should have a reference count of zero. + +The functions should not assume that any \fBTcl_Obj\fR passed in +is unshared. + .SS "THE LENGTHPROC FIELD" .PP The \fBLengthProc\fR function correlates with the \fBTcl_ListObjLength\fR @@ -378,8 +390,11 @@ typedef Tcl_Size .SS "THE INDEXPROC FIELD" .PP The \fBIndexProc\fR function correlates with with the -\fBTcl_ListObjIndex\fR C API. The function returns a Tcl_Obj value for -the element at the specified index. +\fBTcl_ListObjIndex\fR C API. The function should store a pointer to +the element at the specified \fBindex\fR in \fB*elemObj\fR. +Indices that are out of bounds should not be treated as errors; +rather, the function should store a null pointer and +return TCL_OK. .CS typedef int (\fBTcl_ObjTypeIndexProc\fR) ( Tcl_Interp *interp, @@ -404,7 +419,7 @@ typedef int (\fBTcl_ObjTypeSliceProc\fR) ( .PP The \fBReverseProc\fR correlates with the \fBlreverse\fR command, returning a List or Abstract List that has the same elements as the -input Abstract List, with the elements in the reverse order. +input Abstract List, but in reverse order. .CS typedef int (\fBTcl_ObjTypeReverseProc\fR) ( Tcl_Interp *interp, diff --git a/doc/StringObj.3 b/doc/StringObj.3 index f13924a..674a48f 100644 --- a/doc/StringObj.3 +++ b/doc/StringObj.3 @@ -8,7 +8,7 @@ .so man.macros .BS .SH NAME -Tcl_NewStringObj, Tcl_NewUnicodeObj, Tcl_SetStringObj, Tcl_SetUnicodeObj, Tcl_GetStringFromObj, Tcl_GetString, Tcl_GetUnicodeFromObj, Tcl_GetUnicode, Tcl_GetUniChar, Tcl_GetCharLength, Tcl_GetRange, Tcl_AppendToObj, Tcl_AppendUnicodeToObj, Tcl_AppendObjToObj, Tcl_AppendStringsToObj, Tcl_AppendLimitedToObj, Tcl_Format, Tcl_AppendFormatToObj, Tcl_ObjPrintf, Tcl_AppendPrintfToObj, Tcl_SetObjLength, Tcl_AttemptSetObjLength, Tcl_ConcatObj \- manipulate Tcl values as strings +Tcl_NewStringObj, Tcl_NewUnicodeObj, Tcl_SetStringObj, Tcl_SetUnicodeObj, Tcl_GetStringFromObj, Tcl_GetString, Tcl_GetUnicodeFromObj, Tcl_GetUnicode, Tcl_GetUniChar, Tcl_GetCharLength, Tcl_GetRange, Tcl_AppendToObj, Tcl_AppendUnicodeToObj, Tcl_AppendObjToObj, Tcl_AppendStringsToObj, Tcl_AppendLimitedToObj, Tcl_Format, Tcl_AppendFormatToObj, Tcl_ObjPrintf, Tcl_AppendPrintfToObj, Tcl_SetObjLength, Tcl_AttemptSetObjLength, Tcl_ConcatObj, Tcl_IsEmpty \- manipulate Tcl values as strings .SH SYNOPSIS .nf \fB#include <tcl.h>\fR @@ -81,6 +81,9 @@ int .sp Tcl_Obj * \fBTcl_ConcatObj\fR(\fIobjc, objv\fR) +.sp +int +\fBTcl_IsEmpty\fR(\fIfIobjPtr\fR) .fi .SH ARGUMENTS .AS "const Tcl_UniChar" *appendObjPtr in/out @@ -403,6 +406,13 @@ white space, then that value is ignored entirely. This white-space removal was added to make the output of the \fBconcat\fR command cleaner-looking. \fBTcl_ConcatObj\fR returns a pointer to a newly-created value whose ref count is zero. +.PP +The \fBTcl_IsEmpty\fR function returns 1 if \fIobjPtr\fR is the empty +string, 0 otherwise. +It doesn't generate the string representation (unless there +is no other way to do it), so it can safely be called on lists with +billions of elements, or any other data structure for which +it is impossible or expensive to construct the string representation. .SH "REFERENCE COUNT MANAGEMENT" .PP \fBTcl_NewStringObj\fR, \fBTcl_NewUnicodeObj\fR, \fBTcl_Format\fR, diff --git a/doc/registry.n b/doc/registry.n index 4defbad..811ec5f 100644 --- a/doc/registry.n +++ b/doc/registry.n @@ -13,7 +13,7 @@ registry \- Manipulate the Windows registry .SH SYNOPSIS .nf -\fBpackage require registry 1.3\fR +\fBpackage require registry 1.4\fR \fBregistry \fR?\fI\-mode\fR? \fIoption keyName\fR ?\fIarg arg ...\fR? .fi diff --git a/doc/subst.n b/doc/subst.n index 4c9a519..50d0b2b 100644 --- a/doc/subst.n +++ b/doc/subst.n @@ -13,7 +13,10 @@ .SH NAME subst \- Perform backslash, command, and variable substitutions .SH SYNOPSIS +.nf \fBsubst \fR?\fB\-nobackslashes\fR? ?\fB\-nocommands\fR? ?\fB\-novariables\fR? \fIstring\fR +\fBsubst \fR?\fB\-backslashes\fR? ?\fB\-commands\fR? ?\fB\-variables\fR? \fIstring\fR +.fi .BE .SH DESCRIPTION .PP @@ -33,6 +36,18 @@ For example, if \fB\-nocommands\fR is specified, command substitution is not performed: open and close brackets are treated as ordinary characters with no special interpretation. .PP +If any of the \fB\-backslashes\fR, \fB\-commands\fR, or +\fB\-variables\fR are specified, then only the corresponding +substitutions are performed. This means that the following lines are +equivalent: +.PP +.CS +\fBsubst\fR -nobackslashes -nocommands $string +\fBsubst\fR -variables $string +.CE +.PP +It is not allowed to combine positive and negated options. +.PP Note that the substitution of one kind can include substitution of other kinds. For example, even when the \fB\-novariables\fR option is specified, command substitution is performed without restriction. diff --git a/generic/regc_color.c b/generic/regc_color.c index ccb1826..53a7ef5 100644 --- a/generic/regc_color.c +++ b/generic/regc_color.c @@ -412,7 +412,7 @@ newsub( sco = cm->cd[co].sub; if (sco == NOSUB) { /* color has no open subcolor */ if (cm->cd[co].nchrs == 1) { /* optimization */ - return co; + return (color)co; } sco = newcolor(cm); /* must create subcolor */ if (sco == COLORLESS) { diff --git a/generic/regc_nfa.c b/generic/regc_nfa.c index abeb359..1a384cb 100644 --- a/generic/regc_nfa.c +++ b/generic/regc_nfa.c @@ -592,8 +592,8 @@ sortins( { struct arc **sortarray; struct arc *a; - int n = s->nins; - int i; + size_t n = s->nins; + size_t i; if (n <= 1) { return; /* nothing to do */ @@ -668,8 +668,8 @@ sortouts( { struct arc **sortarray; struct arc *a; - int n = s->nouts; - int i; + size_t n = s->nouts; + size_t i; if (n <= 1) { return; /* nothing to do */ @@ -1872,12 +1872,12 @@ fixempties( struct state *nexts; struct arc *a; struct arc *nexta; - int totalinarcs; + size_t totalinarcs; struct arc **inarcsorig; struct arc **arcarray; int arccount; - int prevnins; - int nskip; + size_t prevnins; + size_t nskip; /* * First, get rid of any states whose sole out-arc is an EMPTY, diff --git a/generic/regcomp.c b/generic/regcomp.c index 949f397..e2ce122 100644 --- a/generic/regcomp.c +++ b/generic/regcomp.c @@ -48,7 +48,7 @@ static void parseqatom(struct vars *, int, int, struct state *, struct state *, static void nonword(struct vars *, int, struct state *, struct state *); static void word(struct vars *, int, struct state *, struct state *); static int scannum(struct vars *); -static void repeat(struct vars *, struct state *, struct state *, int, int); +static void repeat(struct vars *, struct state *, struct state *, size_t, size_t); static void bracket(struct vars *, struct state *, struct state *); static void cbracket(struct vars *, struct state *, struct state *); static void brackpart(struct vars *, struct state *, struct state *); @@ -64,8 +64,8 @@ static void markst(struct subre *); static void cleanst(struct vars *); static long nfatree(struct vars *, struct subre *, FILE *); static long nfanode(struct vars *, struct subre *, FILE *); -static int newlacon(struct vars *, struct state *, struct state *, int); -static void freelacons(struct subre *, int); +static size_t newlacon(struct vars *, struct state *, struct state *, size_t); +static void freelacons(struct subre *, size_t); static void rfree(regex_t *); static void dump(regex_t *, FILE *); static void dumpst(struct subre *, FILE *, int); @@ -205,7 +205,7 @@ struct vars { int cflags; /* copy of compile flags */ int lasttype; /* type of previous token */ int nexttype; /* type of next token */ - size_t nextvalue; /* value (if any) of next token */ + chr nextvalue; /* value (if any) of next token */ int lexcon; /* lexical context type (see lex.c) */ size_t nsubexp; /* subexpression count */ struct subre **subs; /* subRE pointer vector */ @@ -685,7 +685,7 @@ parse( NOERRN(); branch->left = parsebranch(v, stopper, type, left, right, 0); NOERRN(); - branch->flags |= UP(branch->flags | branch->left->flags); + branch->flags |= (char)(UP(branch->flags | branch->left->flags)); if ((branch->flags &~ branches->flags) != 0) { /* new flags */ for (t = branches; t != branch; t = t->right) { t->flags |= branch->flags; @@ -788,12 +788,12 @@ parseqatom( { struct state *s; /* temporaries for new states */ struct state *s2; -#define ARCV(t, val) newarc(v->nfa, t, val, lp, rp) - int m, n; +#define ARCV(t, val) newarc(v->nfa, (t), (pcolor)(val), lp, rp) + size_t m, n; struct subre *atom; /* atom's subtree */ struct subre *t; - int cap; /* capturing parens? */ - int pos; /* positive lookahead? */ + size_t cap; /* capturing parens? */ + size_t pos; /* positive lookahead? */ size_t subno; /* capturing-parens or backref number */ int atomtype; int qprefer; /* quantifier short/long preference */ @@ -990,7 +990,7 @@ parseqatom( break; case BACKREF: /* the Feature From The Black Lagoon */ INSIST(type != LACON, REG_ESUBREG); - INSIST(v->nextvalue < v->nsubs, REG_ESUBREG); + INSIST((size_t)v->nextvalue < v->nsubs, REG_ESUBREG); INSIST(v->subs[v->nextvalue] != NULL, REG_ESUBREG); NOERR(); assert(v->nextvalue > 0); @@ -1094,7 +1094,7 @@ parseqatom( if (atom != NULL) { freesubre(v, atom); } - top->flags = f; + top->flags = (char)f; return; } @@ -1204,7 +1204,7 @@ parseqatom( repeat(v, atom->begin, atom->end, m, n); atom->min = (short) m; atom->max = (short) n; - atom->flags |= COMBINE(qprefer, atom->flags); + atom->flags |= (char)COMBINE(qprefer, atom->flags); /* rest of branch can be strung starting from atom->end */ s2 = atom->end; } else if (m == 1 && n == 1) { @@ -1268,8 +1268,8 @@ parseqatom( } NOERR(); assert(SEE('|') || SEE(stopper) || SEE(EOS)); - t->flags |= COMBINE(t->flags, t->right->flags); - top->flags |= COMBINE(top->flags, t->flags); + t->flags |= (char)COMBINE(t->flags, t->right->flags); + top->flags |= (char)COMBINE(top->flags, t->flags); } /* @@ -1346,13 +1346,13 @@ repeat( struct vars *v, struct state *lp, struct state *rp, - int m, - int n) + size_t m, + size_t n) { #define SOME 2 #define INF 3 #define PAIR(x, y) ((x)*4 + (y)) -#define REDUCE(x) ( ((x) == DUPINF) ? INF : (((x) > 1) ? SOME : (x)) ) +#define REDUCE(x) ( ((x) == DUPINF) ? INF : (((x) > 1) ? SOME : (int)(x)) ) const int rm = REDUCE(m); const int rn = REDUCE(n); struct state *s, *s2; @@ -1660,7 +1660,7 @@ dovec( { chr ch, from, to; const chr *p; - int i; + size_t i; for (p = cv->chrs, i = cv->nchrs; i > 0; p++, i--) { ch = *p; @@ -1744,8 +1744,8 @@ sub_re( assert(strchr("=b|.*(", op) != NULL); - ret->op = op; - ret->flags = flags; + ret->op = (char)op; + ret->flags = (char)flags; ret->id = 0; /* will be assigned later */ ret->subno = 0; ret->min = ret->max = 1; @@ -1944,16 +1944,16 @@ nfanode( /* - newlacon - allocate a lookahead-constraint subRE - ^ static int newlacon(struct vars *, struct state *, struct state *, int); + ^ static size_t newlacon(struct vars *, struct state *, struct state *, size_t); */ -static int /* lacon number */ +static size_t /* lacon number */ newlacon( struct vars *v, struct state *begin, struct state *end, - int pos) + size_t pos) { - int n; + size_t n; struct subre *newlacons; struct subre *sub; @@ -1988,10 +1988,10 @@ newlacon( static void freelacons( struct subre *subs, - int n) + size_t n) { struct subre *sub; - int i; + size_t i; assert(n > 0); for (sub=subs+1, i=n-1; i>0; sub++, i--) { /* no 0th */ @@ -2135,7 +2135,7 @@ stdump( fprintf(f, " UNUSED"); } if (t->subno != 0) { - fprintf(f, " (#%d)", t->subno); + fprintf(f, " (#%" TCL_Z_MODIFIER "d)", t->subno); } if (t->min != 1 || t->max != 1) { fprintf(f, " {%d,", t->min); diff --git a/generic/rege_dfa.c b/generic/rege_dfa.c index 9602a71..c5196c9 100644 --- a/generic/rege_dfa.c +++ b/generic/rege_dfa.c @@ -414,14 +414,14 @@ freeDFA( /* - hash - construct a hash code for a bitvector * There are probably better ways, but they're more expensive. - ^ static unsigned hash(unsigned *, int); + ^ static unsigned hash(unsigned *, size_t); */ static unsigned hash( unsigned *const uv, - int n) + size_t n) { - int i; + size_t i; unsigned h; h = 0; diff --git a/generic/regexec.c b/generic/regexec.c index 7b84f0f..79074a9 100644 --- a/generic/regexec.c +++ b/generic/regexec.c @@ -145,7 +145,7 @@ static chr *shortest(struct vars *const, struct dfa *const, chr *const, chr *con static chr *lastCold(struct vars *const, struct dfa *const); static struct dfa *newDFA(struct vars *const, struct cnfa *const, struct colormap *const, struct smalldfa *); static void freeDFA(struct dfa *const); -static unsigned hash(unsigned *const, int); +static unsigned hash(unsigned *const, size_t); static struct sset *initialize(struct vars *const, struct dfa *const, chr *const); static struct sset *miss(struct vars *const, struct dfa *const, struct sset *const, const pcolor, chr *const, chr *const); static int checkLAConstraint(struct vars *const, struct cnfa *const, chr *const, const pcolor); @@ -171,8 +171,8 @@ exec( { AllocVars(v); int st, backref; - int n; - int i; + size_t n; + size_t i; #define LOCALMAT 20 regmatch_t mat[LOCALMAT]; #define LOCALDFAS 40 @@ -592,7 +592,7 @@ subset( chr *const begin, chr *const end) { - int n = sub->subno; + size_t n = sub->subno; assert(n > 0); if ((size_t)n >= v->nmatch) { @@ -874,7 +874,8 @@ cbrdissect( chr *begin, /* beginning of relevant substring */ chr *end) /* end of same */ { - int n = t->subno, min = t->min, max = t->max; + size_t n = t->subno; + int min = t->min, max = t->max; size_t numreps; size_t tlen; size_t brlen; diff --git a/generic/regguts.h b/generic/regguts.h index e135874..3d543ef 100644 --- a/generic/regguts.h +++ b/generic/regguts.h @@ -364,7 +364,7 @@ struct subre { #define PREF2(f1, f2) ((PREF(f1) != 0) ? PREF(f1) : PREF(f2)) #define COMBINE(f1, f2) (UP((f1)|(f2)) | PREF2(f1, f2)) short id; /* ID of subre (1..ntree-1) */ - int subno; /* subexpression number (for 'b' and '(') */ + size_t subno; /* subexpression number (for 'b' and '(') */ short min; /* min repetitions for iteration or backref */ short max; /* max repetitions for iteration or backref */ struct subre *left; /* left child, if any (also freelist chain) */ diff --git a/generic/tcl.decls b/generic/tcl.decls index d225050..f36ecd5 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -40,22 +40,22 @@ declare 2 { TCL_NORETURN void Tcl_Panic(const char *format, ...) } declare 3 { - void *Tcl_Alloc(TCL_HASH_TYPE size) + void *Tcl_Alloc(size_t size) } declare 4 { void Tcl_Free(void *ptr) } declare 5 { - void *Tcl_Realloc(void *ptr, TCL_HASH_TYPE size) + void *Tcl_Realloc(void *ptr, size_t size) } declare 6 { - void *Tcl_DbCkalloc(TCL_HASH_TYPE size, const char *file, int line) + void *Tcl_DbCkalloc(size_t size, const char *file, int line) } declare 7 { void Tcl_DbCkfree(void *ptr, const char *file, int line) } declare 8 { - void *Tcl_DbCkrealloc(void *ptr, TCL_HASH_TYPE size, + void *Tcl_DbCkrealloc(void *ptr, size_t size, const char *file, int line) } @@ -129,17 +129,6 @@ declare 29 { declare 30 { void TclFreeObj(Tcl_Obj *objPtr) } -declare 31 { - int Tcl_GetBoolean(Tcl_Interp *interp, const char *src, int *intPtr) -} -declare 32 { - int Tcl_GetBooleanFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, - int *intPtr) -} -# Only available in Tcl 8.x, NULL in Tcl 9.0 -declare 33 { - unsigned char *Tcl_GetByteArrayFromObj(Tcl_Obj *objPtr, Tcl_Size *numBytesPtr) -} declare 34 { int Tcl_GetDouble(Tcl_Interp *interp, const char *src, double *doublePtr) } @@ -259,10 +248,6 @@ declare 79 { declare 80 { void Tcl_CancelIdleCall(Tcl_IdleProc *idleProc, void *clientData) } -# Only available in Tcl 8.x, NULL in Tcl 9.0 -declare 81 { - int Tcl_Close(Tcl_Interp *interp, Tcl_Channel chan) -} declare 82 { int Tcl_CommandComplete(const char *cmd) } @@ -1053,9 +1038,6 @@ declare 338 { declare 339 { Tcl_Size Tcl_WriteObj(Tcl_Channel chan, Tcl_Obj *objPtr) } -declare 340 { - char *Tcl_GetString(Tcl_Obj *objPtr) -} declare 343 { void Tcl_AlertNotifier(void *clientData) } @@ -1217,7 +1199,7 @@ declare 392 { } declare 393 { int Tcl_CreateThread(Tcl_ThreadId *idPtr, Tcl_ThreadCreateProc *proc, - void *clientData, TCL_HASH_TYPE stackSize, int flags) + void *clientData, size_t stackSize, int flags) } # Introduced in 8.3.2 @@ -1303,6 +1285,10 @@ declare 417 { declare 418 { int Tcl_IsChannelExisting(const char *channelName) } +declare 421 { + Tcl_HashEntry *Tcl_DbCreateHashEntry(Tcl_HashTable *tablePtr, + const void *key, int *newPtr, const char *file, int line) +} declare 422 { Tcl_HashEntry *Tcl_CreateHashEntry(Tcl_HashTable *tablePtr, const void *key, int *newPtr) @@ -1328,16 +1314,16 @@ declare 427 { int flags, Tcl_CommandTraceProc *proc, void *clientData) } declare 428 { - void *Tcl_AttemptAlloc(TCL_HASH_TYPE size) + void *Tcl_AttemptAlloc(size_t size) } declare 429 { - void *Tcl_AttemptDbCkalloc(TCL_HASH_TYPE size, const char *file, int line) + void *Tcl_AttemptDbCkalloc(size_t size, const char *file, int line) } declare 430 { - void *Tcl_AttemptRealloc(void *ptr, TCL_HASH_TYPE size) + void *Tcl_AttemptRealloc(void *ptr, size_t size) } declare 431 { - void *Tcl_AttemptDbCkrealloc(void *ptr, TCL_HASH_TYPE size, + void *Tcl_AttemptDbCkrealloc(void *ptr, size_t size, const char *file, int line) } declare 432 { @@ -2148,7 +2134,7 @@ declare 636 { } declare 637 { char *Tcl_InitStringRep(Tcl_Obj *objPtr, const char *bytes, - TCL_HASH_TYPE numBytes) + size_t numBytes) } declare 638 { Tcl_ObjInternalRep *Tcl_FetchInternalRep(Tcl_Obj *objPtr, const Tcl_ObjType *typePtr) @@ -2381,7 +2367,33 @@ declare 689 { # ----- BASELINE -- FOR -- 9.0.0 ----- # +# TIP 711 declare 690 { + int Tcl_IsEmpty(Tcl_Obj *obj) +} + +# TIP 716 +declare 691 { + const char *Tcl_GetEncodingNameForUser(Tcl_DString *bufPtr) +} + +# TIP 649 +declare 692 { + int Tcl_ListObjReverse(Tcl_Interp *interp, Tcl_Obj *objPtr, + Tcl_Obj **resultPtrPtr) +} +declare 693 { + int Tcl_ListObjRepeat(Tcl_Interp *interp, Tcl_Size repeatCount, + Tcl_Size objc, Tcl_Obj *const objv[], Tcl_Obj **resultPtrPtr) +} +declare 694 { + int Tcl_ListObjRange(Tcl_Interp *interp, Tcl_Obj *objPtr, + Tcl_Size start, Tcl_Size end, Tcl_Obj **resultPtrPtr) +} + +# ----- BASELINE -- FOR -- 9.1.0 ----- # + +declare 695 { void TclUnusedStubEntry(void) } diff --git a/generic/tcl.h b/generic/tcl.h index e6f0f7f..b755c04 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -49,14 +49,15 @@ extern "C" { #if !defined(TCL_MAJOR_VERSION) # define TCL_MAJOR_VERSION 9 #endif -#if TCL_MAJOR_VERSION == 9 -# define TCL_MINOR_VERSION 0 -# define TCL_RELEASE_LEVEL TCL_FINAL_RELEASE -# define TCL_RELEASE_SERIAL 3 - -# define TCL_VERSION "9.0" -# define TCL_PATCH_LEVEL "9.0.3" -#endif /* TCL_MAJOR_VERSION */ +#if TCL_MAJOR_VERSION != 9 +# error "This header-file is for Tcl 9 only" +#endif +#define TCL_MINOR_VERSION 1 +#define TCL_RELEASE_LEVEL TCL_ALPHA_RELEASE +#define TCL_RELEASE_SERIAL 1 + +#define TCL_VERSION "9.1" +#define TCL_PATCH_LEVEL "9.1a1" #if defined(RC_INVOKED) /* @@ -321,30 +322,12 @@ typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt; #define Tcl_WideAsDouble(val) ((double)((Tcl_WideInt)(val))) #define Tcl_DoubleAsWide(val) ((Tcl_WideInt)((double)(val))) -#if TCL_MAJOR_VERSION < 9 -# ifndef Tcl_Size - typedef int Tcl_Size; -# endif -# ifndef TCL_SIZE_MAX -# define TCL_SIZE_MAX ((int)(((unsigned int)-1)>>1)) -# endif -# ifndef TCL_SIZE_MODIFIER -# define TCL_SIZE_MODIFIER "" -#endif -#else - typedef ptrdiff_t Tcl_Size; -# define TCL_SIZE_MAX ((Tcl_Size)(((size_t)-1)>>1)) -# define TCL_SIZE_MODIFIER TCL_T_MODIFIER -#endif /* TCL_MAJOR_VERSION */ +typedef ptrdiff_t Tcl_Size; +#define TCL_SIZE_MAX ((Tcl_Size)(((size_t)-1)>>1)) +#define TCL_SIZE_MODIFIER TCL_T_MODIFIER #ifdef _WIN32 -# if TCL_MAJOR_VERSION > 8 || defined(_WIN64) || defined(_USE_64BIT_TIME_T) - typedef struct __stat64 Tcl_StatBuf; -# elif defined(_USE_32BIT_TIME_T) - typedef struct _stati64 Tcl_StatBuf; -# else - typedef struct _stat32i64 Tcl_StatBuf; -# endif + typedef struct __stat64 Tcl_StatBuf; #elif defined(__CYGWIN__) typedef struct { unsigned st_dev; @@ -425,7 +408,7 @@ typedef void (Tcl_ThreadCreateProc) (void *clientData); * given to Tcl_CreateThread. */ -#define TCL_THREAD_STACK_DEFAULT (0) /* Use default size for stack. */ +#define TCL_THREAD_STACK_DEFAULT (0) /* Use default size for stack. */ #define TCL_THREAD_NOFLAGS (0000) /* Standard flags, default * behaviour. */ #define TCL_THREAD_JOINABLE (0001) /* Mark the thread as joinable. */ @@ -469,28 +452,18 @@ typedef void (Tcl_ThreadCreateProc) (void *clientData); */ typedef struct Tcl_RegExpIndices { -#if TCL_MAJOR_VERSION > 8 Tcl_Size start; /* Character offset of first character in * match. */ Tcl_Size end; /* Character offset of first character after * the match. */ -#else - long start; - long end; -#endif } Tcl_RegExpIndices; typedef struct Tcl_RegExpInfo { Tcl_Size nsubs; /* Number of subexpressions in the compiled * expression. */ Tcl_RegExpIndices *matches; /* Array of nsubs match offset pairs. */ -#if TCL_MAJOR_VERSION > 8 Tcl_Size extendStart; /* The offset at which a subsequent match * might begin. */ -#else - long extendStart; - long reserved; /* Reserved for later use. */ -#endif } Tcl_RegExpInfo; /* @@ -589,7 +562,6 @@ typedef void (Tcl_InterpDeleteProc) (void *clientData, typedef void (Tcl_NamespaceDeleteProc) (void *clientData); typedef int (Tcl_ObjCmdProc) (void *clientData, Tcl_Interp *interp, int objc, struct Tcl_Obj *const *objv); -#if TCL_MAJOR_VERSION > 8 typedef int (Tcl_ObjCmdProc2) (void *clientData, Tcl_Interp *interp, Tcl_Size objc, struct Tcl_Obj *const *objv); typedef int (Tcl_CmdObjTraceProc2) (void *clientData, Tcl_Interp *interp, @@ -600,11 +572,6 @@ typedef void (Tcl_FreeProc) (void *blockPtr); #define Tcl_FileFreeProc Tcl_FreeProc #define Tcl_FileFreeProc Tcl_FreeProc #define Tcl_EncodingFreeProc Tcl_FreeProc -#else -#define Tcl_ObjCmdProc2 Tcl_ObjCmdProc -#define Tcl_CmdObjTraceProc2 Tcl_CmdObjTraceProc -typedef void (Tcl_FreeProc) (char *blockPtr); -#endif typedef int (Tcl_LibraryInitProc) (Tcl_Interp *interp); typedef int (Tcl_LibraryUnloadProc) (Tcl_Interp *interp, int flags); typedef void (Tcl_PanicProc) (const char *format, ...); @@ -673,7 +640,6 @@ typedef struct Tcl_ObjType { /* Called to convert the object's internal rep * to this type. Frees the internal rep of the * old type. Returns TCL_ERROR on failure. */ -#if TCL_MAJOR_VERSION > 8 size_t version; /* Version field for future-proofing. */ /* List emulation functions - ObjType Version 1 */ @@ -697,21 +663,14 @@ typedef struct Tcl_ObjType { /* "in" and "ni" expr list operation. * Determine if the given string value matches * an element in the list. */ -#endif } Tcl_ObjType; -#if TCL_MAJOR_VERSION > 8 -# define TCL_OBJTYPE_V0 0, \ - 0,0,0,0,0,0,0,0 /* Pre-Tcl 9 */ -# define TCL_OBJTYPE_V1(a) offsetof(Tcl_ObjType, indexProc), \ - a,0,0,0,0,0,0,0 /* Tcl 9 Version 1 */ -# define TCL_OBJTYPE_V2(a,b,c,d,e,f,g,h) sizeof(Tcl_ObjType), \ - a,b,c,d,e,f,g,h /* Tcl 9 - AbstractLists */ -#else -# define TCL_OBJTYPE_V0 /* just empty */ -# define TCL_OBJTYPE_V1(a) /* just empty */ -# define TCL_OBJTYPE_V2(a,b,c,d,e,f,g,h) /* just empty */ -#endif +#define TCL_OBJTYPE_V0 0, \ + 0,0,0,0,0,0,0,0 /* Pre-Tcl 9 */ +#define TCL_OBJTYPE_V1(a) offsetof(Tcl_ObjType, indexProc), \ + a,0,0,0,0,0,0,0 /* Tcl 9 Version 1 */ +#define TCL_OBJTYPE_V2(a,b,c,d,e,f,g,h) sizeof(Tcl_ObjType), \ + a,b,c,d,e,f,g,h /* Tcl 9 - AbstractLists */ /* * The following structure stores an internal representation (internalrep) for @@ -720,7 +679,7 @@ typedef struct Tcl_ObjType { * the handling of the internalrep. */ -typedef union Tcl_ObjInternalRep { /* The internal representation: */ +typedef union Tcl_ObjInternalRep {/* The internal representation: */ long longValue; /* - an long integer value. */ double doubleValue; /* - a double-precision floating value. */ void *otherValuePtr; /* - another, type-specific value, */ @@ -957,11 +916,7 @@ typedef struct Tcl_DString { * TCL_COMBINE Combine surrogates */ -#if TCL_MAJOR_VERSION > 8 -# define TCL_COMBINE 0x1000000 -#else -# define TCL_COMBINE 0 -#endif +#define TCL_COMBINE 0x1000000 /* *---------------------------------------------------------------------------- * Flag values passed to Tcl_RecordAndEval, Tcl_EvalObj, Tcl_EvalObjv. @@ -1066,18 +1021,14 @@ typedef struct Tcl_DString { */ #ifndef TCL_HASH_TYPE -#if TCL_MAJOR_VERSION > 8 -# define TCL_HASH_TYPE size_t -#else -# define TCL_HASH_TYPE unsigned -#endif +# define TCL_HASH_TYPE size_t #endif typedef struct Tcl_HashKeyType Tcl_HashKeyType; typedef struct Tcl_HashTable Tcl_HashTable; typedef struct Tcl_HashEntry Tcl_HashEntry; -typedef TCL_HASH_TYPE (Tcl_HashKeyProc) (Tcl_HashTable *tablePtr, void *keyPtr); +typedef size_t (Tcl_HashKeyProc) (Tcl_HashTable *tablePtr, void *keyPtr); typedef int (Tcl_CompareHashKeysProc) (void *keyPtr, Tcl_HashEntry *hPtr); typedef Tcl_HashEntry * (Tcl_AllocHashEntryProc) (Tcl_HashTable *tablePtr, void *keyPtr); @@ -1195,21 +1146,20 @@ struct Tcl_HashTable { * table. */ Tcl_Size rebuildSize; /* Enlarge table when numEntries gets to be * this large. */ -#if TCL_MAJOR_VERSION > 8 size_t mask; /* Mask value used in hashing function. */ -#endif int downShift; /* Shift count used in hashing function. * Designed to use high-order bits of * randomized keys. */ -#if TCL_MAJOR_VERSION < 9 - int mask; /* Mask value used in hashing function. */ -#endif int keyType; /* Type of keys used in this table. It's * either TCL_CUSTOM_KEYS, TCL_STRING_KEYS, * TCL_ONE_WORD_KEYS, or an integer giving the * number of ints that is the size of the * key. */ +#ifndef TCL_NO_DEPRECATED Tcl_HashEntry *(*findProc) (Tcl_HashTable *tablePtr, const char *key); +#else + void *unUsed; +#endif Tcl_HashEntry *(*createProc) (Tcl_HashTable *tablePtr, const char *key, int *newPtr); const Tcl_HashKeyType *typePtr; @@ -1265,7 +1215,7 @@ typedef struct Tcl_HashSearch { typedef struct { void *next; /* Search position for underlying hash * table. */ - TCL_HASH_TYPE epoch; /* Epoch marker for dictionary being searched, + size_t epoch; /* Epoch marker for dictionary being searched, * or 0 if search has terminated. */ Tcl_Dict dictionaryPtr; /* Reference to dictionary being searched. */ } Tcl_DictSearch; @@ -1321,12 +1271,8 @@ typedef enum { */ typedef struct Tcl_Time { -#if TCL_MAJOR_VERSION > 8 long long sec; /* Seconds. */ -#else - long sec; /* Seconds. */ -#endif -#if defined(_CYGWIN_) && TCL_MAJOR_VERSION > 8 +#if defined(_CYGWIN_) int usec; /* Microseconds. */ #else long usec; /* Microseconds. */ @@ -1377,11 +1323,7 @@ typedef void (Tcl_ScaleTimeProc) (Tcl_Time *timebuf, void *clientData); * interface. */ -#if TCL_MAJOR_VERSION > 8 -# define TCL_CLOSE2PROC NULL -#else -# define TCL_CLOSE2PROC ((void *) 1) -#endif +#define TCL_CLOSE2PROC NULL /* * Channel version tag. This was introduced in 8.3.2/8.4. @@ -1929,12 +1871,10 @@ typedef struct Tcl_Parse { * *tokenPtr. */ int errorType; /* One of the parsing error types defined * above. */ -#if TCL_MAJOR_VERSION > 8 int incomplete; /* This field is set to 1 by Tcl_ParseCommand * if the command appears to be incomplete. * This information is used by * Tcl_CommandComplete. */ -#endif /* * The fields below are intended only for the private use of the parser. @@ -1953,9 +1893,6 @@ typedef struct Tcl_Parse { * beginning of region where the error * occurred (e.g. the open brace if the close * brace is missing). */ -#if TCL_MAJOR_VERSION < 9 - int incomplete; -#endif Tcl_Token staticTokens[NUM_STATIC_TOKENS]; /* Initial space for tokens for command. This * space should be large enough to accommodate @@ -2036,11 +1973,7 @@ typedef struct Tcl_EncodingType { #define TCL_ENCODING_START 0x01 #define TCL_ENCODING_END 0x02 -#if TCL_MAJOR_VERSION > 8 -# define TCL_ENCODING_STOPONERROR 0x0 /* Not used any more */ -#else -# define TCL_ENCODING_STOPONERROR 0x04 -#endif +#define TCL_ENCODING_STOPONERROR 0x0 /* Not used any more */ #define TCL_ENCODING_NO_TERMINATE 0x08 #define TCL_ENCODING_CHAR_LIMIT 0x10 /* Internal use bits, do not define bits in this space. See above comment */ @@ -2050,7 +1983,7 @@ typedef struct Tcl_EncodingType { * changes, ensure ENCODING_PROFILE_* macros in tclInt.h are modified if * necessary. */ -#define TCL_ENCODING_PROFILE_STRICT TCL_ENCODING_STOPONERROR +#define TCL_ENCODING_PROFILE_STRICT 0x00000000 #define TCL_ENCODING_PROFILE_TCL8 0x01000000 #define TCL_ENCODING_PROFILE_REPLACE 0x02000000 @@ -2093,11 +2026,7 @@ typedef struct Tcl_EncodingType { */ #ifndef TCL_UTF_MAX -# if defined(BUILD_tcl) || TCL_MAJOR_VERSION > 8 -# define TCL_UTF_MAX 4 -# else -# define TCL_UTF_MAX 3 -# endif +# define TCL_UTF_MAX 4 #endif /* @@ -2105,7 +2034,7 @@ typedef struct Tcl_EncodingType { * reflected in regcustom.h. */ -#if TCL_UTF_MAX == 4 && TCL_MAJOR_VERSION > 8 +#if TCL_UTF_MAX == 4 /* * int isn't 100% accurate as it should be a strict 4-byte value * (perhaps int32_t). ILP64/SILP64 systems may have troubles. The @@ -2146,11 +2075,7 @@ typedef struct Tcl_Config { */ typedef void (Tcl_LimitHandlerProc) (void *clientData, Tcl_Interp *interp); -#if TCL_MAJOR_VERSION > 8 #define Tcl_LimitHandlerDeleteProc Tcl_FreeProc -#else -typedef void (Tcl_LimitHandlerDeleteProc) (void *clientData); -#endif #if 0 /* @@ -2307,11 +2232,7 @@ typedef int (Tcl_NRPostProc) (void *data[], Tcl_Interp *interp, * stubs tables. */ -#if TCL_MAJOR_VERSION > 8 -# define TCL_STUB_MAGIC ((int) 0xFCA3BACB + (int) sizeof(void *)) -#else -# define TCL_STUB_MAGIC ((int) 0xFCA3BACF) -#endif +#define TCL_STUB_MAGIC ((int) 0xFCA3BACB + (int) sizeof(void *)) /* * The following function is required to be defined in all stubs aware @@ -2333,28 +2254,15 @@ void * TclStubCall(void *arg); #endif #ifdef USE_TCL_STUBS -#if TCL_MAJOR_VERSION < 9 -# define Tcl_InitStubs(interp, version, exact) \ - (Tcl_InitStubs)(interp, version, \ - (exact)|(TCL_MAJOR_VERSION<<8)|(0xFF<<16), \ - TCL_STUB_MAGIC) -#else # define Tcl_InitStubs(interp, version, exact) \ (Tcl_InitStubs)(interp, version, \ (exact)|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16), \ TCL_STUB_MAGIC) -#endif -#else -#if TCL_MAJOR_VERSION < 9 -# define Tcl_InitStubs(interp, version, exact) \ - Tcl_Panic(((void)interp, (void)version, \ - (void)exact, "Please define -DUSE_TCL_STUBS")) #else # define Tcl_InitStubs(interp, version, exact) \ Tcl_PkgInitStubsCheck(interp, version, \ (exact)|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16)) #endif -#endif /* * Public functions that are not accessible via the stubs table. @@ -2394,7 +2302,7 @@ EXTERN const char *TclZipfs_AppHook(int *argc, char ***argv); EXTERN TCL_NORETURN void Tcl_MainExW(Tcl_Size argc, wchar_t **argv, Tcl_AppInitProc *appInitProc, Tcl_Interp *interp); #endif -#if defined(USE_TCL_STUBS) && (TCL_MAJOR_VERSION > 8) +#if defined(USE_TCL_STUBS) #define Tcl_SetPanicProc(panicProc) \ TclInitStubTable(((const char *(*)(Tcl_PanicProc *))TclStubCall((void *)panicProc))(panicProc)) #define Tcl_InitSubsystems() \ @@ -2505,12 +2413,12 @@ EXTERN const char *TclZipfs_AppHook(int *argc, char ***argv); static inline void TclBounceRefCount( Tcl_Obj* objPtr, - const char* fn, + const char* file, int line) { if (objPtr) { if ((objPtr)->refCount == 0) { - Tcl_DbDecrRefCount(objPtr, fn, line); + Tcl_DbDecrRefCount(objPtr, file, line); } } } @@ -2606,9 +2514,14 @@ TclBounceRefCount( */ #define Tcl_FindHashEntry(tablePtr, key) \ - (*((tablePtr)->findProc))(tablePtr, (const char *)(key)) -#define Tcl_CreateHashEntry(tablePtr, key, newPtr) \ + (*((tablePtr)->createProc))(tablePtr, (const char *)(key), (int *)-1) +#define Tcl_AttemptCreateHashEntry(tablePtr, key, newPtr) \ (*((tablePtr)->createProc))(tablePtr, (const char *)(key), newPtr) +#ifdef TCL_MEM_DEBUG +#undef Tcl_CreateHashEntry +#define Tcl_CreateHashEntry(tablePtr, key, newPtr) \ + Tcl_DbCreateHashEntry(tablePtr, key, newPtr, __FILE__, __LINE__) +#endif #endif /* RC_INVOKED */ diff --git a/generic/tclArithSeries.c b/generic/tclArithSeries.c index 6272218..65d12be 100755 --- a/generic/tclArithSeries.c +++ b/generic/tclArithSeries.c @@ -217,7 +217,7 @@ ArithSeriesGetInternalRep( } /* - * Compute number of significant fractional digits + * Compute number of significant fractional digits. */ static inline unsigned ObjPrecision( @@ -228,8 +228,7 @@ ObjPrecision( if (TclHasInternalRep(numObj, &tclDoubleType) || ( Tcl_GetNumberFromObj(NULL, numObj, &ptr, &type) == TCL_OK - && type == TCL_NUMBER_DOUBLE) - ) { /* TCL_NUMBER_DOUBLE */ + && type == TCL_NUMBER_DOUBLE)) { const char *str = TclGetString(numObj); if (strchr(str, 'e') == NULL && strchr(str, 'E') == NULL) { @@ -275,15 +274,13 @@ maxObjPrecision( * * ArithSeriesLen -- * - * Compute the length of the equivalent list where - * every element is generated starting from *start*, - * and adding *step* to generate every successive element - * that's < *end* for positive steps, or > *end* for negative - * steps. + * Compute the length of the equivalent list where every element is + * generated starting from *start*, and adding *step* to generate every + * successive element that's < *end* for positive steps, or > *end* for + * negative steps. * * Results: - * The length of the list generated by the given range, - * that may be zero. + * The length of the list generated by the given range, that may be zero. * The function returns -1 if the list is of length infinite. * * Side effects: @@ -485,7 +482,7 @@ NewArithSeriesInt( } /* First, step*number of intervals should not overflow */ if ((UWIDE_MAX / absoluteStep) < (Tcl_WideUInt) numIntervals) { - goto invalid_range; + goto invalidRange; } if (step > 0) { /* @@ -493,11 +490,11 @@ NewArithSeriesInt( * second term will not underflow a Tcl_WideInt */ if (start > (WIDE_MAX - (step * numIntervals))) { - goto invalid_range; + goto invalidRange; } } else if (step == WIDE_MIN) { if (numIntervals > 0 || start < 0) { - goto invalid_range; + goto invalidRange; } } else if (step < 0) { /* @@ -506,7 +503,7 @@ NewArithSeriesInt( * DON'T use absoluteStep here because of unsigned type promotion */ if (start < (WIDE_MIN + ((-step) * numIntervals))) { - goto invalid_range; + goto invalidRange; } } else /* step == 0 */ { /* TODO - step == 0 && length > 1 should be error? */ @@ -527,7 +524,7 @@ NewArithSeriesInt( return arithSeriesObj; -invalid_range: + invalidRange: Tcl_BounceRefCount(arithSeriesObj); return NULL; } @@ -546,6 +543,7 @@ invalid_range: * * Side Effects: * None. + * *---------------------------------------------------------------------- */ static Tcl_Obj * @@ -603,6 +601,7 @@ NewArithSeriesDbl( * * Side Effects: * None. + * *---------------------------------------------------------------------- */ static int @@ -664,6 +663,7 @@ assignNumber( * * Side Effects: * None. + * *---------------------------------------------------------------------- */ Tcl_Obj * @@ -681,6 +681,8 @@ TclNewArithSeriesObj( Tcl_WideInt len = -1; Tcl_Obj *objPtr; unsigned precision = (unsigned)-1; /* unknown precision */ + const char *description; + char tmp[TCL_DOUBLE_SPACE + 2] = {0}; if (startObj) { if (assignNumber(interp, useDoubles, &start, &dstart, startObj) != TCL_OK) { @@ -699,15 +701,11 @@ TclNewArithSeriesObj( return objPtr; } } - if (endObj) { - if (assignNumber(interp, useDoubles, &end, &dend, endObj) != TCL_OK) { - return NULL; - } + if (endObj && assignNumber(interp, useDoubles, &end, &dend, endObj) != TCL_OK) { + return NULL; } - if (lenObj) { - if (Tcl_GetWideIntFromObj(interp, lenObj, &len) != TCL_OK) { - return NULL; - } + if (lenObj && Tcl_GetWideIntFromObj(interp, lenObj, &len) != TCL_OK) { + return NULL; } if (endObj) { @@ -724,24 +722,13 @@ TclNewArithSeriesObj( } } } - assert(dstep!=0); + assert(dstep != 0); if (!lenObj) { if (useDoubles) { if (isinf(dstart) || isinf(dend)) { goto exceeded; - } - if (isnan(dstart) || isnan(dend)) { - const char *description = "non-numeric floating-point value"; - char tmp[TCL_DOUBLE_SPACE + 2]; - - tmp[0] = '\0'; - Tcl_PrintDouble(NULL, isnan(dstart)?dstart:dend, tmp); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "cannot use %s \"%s\" to estimate length of arith-series", - description, tmp)); - Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", description, - (char *)NULL); - return NULL; + } else if (isnan(dstart) || isnan(dend)) { + goto notANumber; } precision = maxObjPrecision(startObj, endObj, stepObj); len = ArithSeriesLenDbl(dstart, dend, dstep, precision); @@ -749,16 +736,14 @@ TclNewArithSeriesObj( len = ArithSeriesLenInt(start, end, step); } } - } else { - if (useDoubles) { - // Compute precision based on given command argument values - precision = maxObjPrecision(startObj, NULL, stepObj); - - dend = dstart + (dstep * (double)(len-1)); - // Make computed end value match argument(s) precision - dend = ArithRound(dend, precision); - end = dend; - } + } else if (useDoubles) { + // Compute precision based on given command argument values + precision = maxObjPrecision(startObj, NULL, stepObj); + + dend = dstart + (dstep * (double)(len-1)); + // Make computed end value match argument(s) precision + dend = ArithRound(dend, precision); + end = dend; } /* @@ -767,11 +752,7 @@ TclNewArithSeriesObj( * (0x0ffffffffffffffa instead of 0x7fffffffffffffff by 64bit) */ if (len > TCL_SIZE_MAX) { - exceeded: - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "max length of a Tcl list exceeded", TCL_AUTO_LENGTH)); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL); - return NULL; + goto exceeded; } if (useDoubles) { @@ -779,10 +760,8 @@ TclNewArithSeriesObj( * so simply check the end of it and behave like [expr {Inf - Inf}] */ double d = dstart + (double)(len - 1) * dstep; if (isnan(d)) { - const char *s = "domain error: argument not in valid range"; - Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1)); - Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", s, (char *)NULL); - return NULL; + description = "domain error: argument not in valid range"; + goto domain; } if (precision == (unsigned)-1) { @@ -795,11 +774,30 @@ TclNewArithSeriesObj( } if (objPtr == NULL && interp) { - const char *description = "invalid arithmetic series parameter values"; - Tcl_SetResult(interp, description, TCL_STATIC); - Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", description, (char *)NULL); + description = "invalid arithmetic series parameter values"; + goto domain; } return objPtr; + + exceeded: + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "max length of a Tcl list exceeded", TCL_AUTO_LENGTH)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL); + return NULL; + + domain: + Tcl_SetObjResult(interp, Tcl_NewStringObj(description, TCL_AUTO_LENGTH)); + Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", description, (char *)NULL); + return NULL; + + notANumber: + description = "non-numeric floating-point value"; + Tcl_PrintDouble(NULL, isnan(dstart) ? dstart : dend, tmp); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "cannot use %s \"%s\" to estimate length of arith-series", + description, tmp)); + Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", description, (char *)NULL); + return NULL; } /* diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 7283b0a..7f5a257 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -23,9 +23,8 @@ *- expandStart, expandStkTop, invokeExpanded, expandDrop *- dictFirst, dictNext, dictDone *- dictUpdateStart, dictUpdateEnd - *- jumpTable testing + *- jumpTable and jumpTableNum testing *- syntax (?) - *- returnCodeBranch *- tclooNext, tclooNextClass */ @@ -62,8 +61,6 @@ typedef enum BasicBlockCatchState { */ typedef struct BasicBlock { - int originalStartOffset; /* Instruction offset before JUMP1s were - * substituted with JUMP4's */ int startOffset; /* Instruction offset of the start of the * block */ int startLine; /* Line number in the input script of the @@ -103,6 +100,8 @@ typedef struct BasicBlock { * ranges belonging to embedded scripts and * expressions in this block */ JumptableInfo* jtPtr; /* Jump table at the end of this basic block */ + JumptableNumInfo* jtnPtr; /* Numeric jump table at the end of this basic + * block */ int flags; /* Boolean flags */ } BasicBlock; @@ -115,8 +114,6 @@ enum BasicBlockFlags { * traversal */ BB_FALLTHRU = (1 << 1), /* Control may pass from this block to a * successor */ - BB_JUMP1 = (1 << 2), /* Basic block ends with a 1-byte-offset jump - * and may need expansion */ BB_JUMPTABLE = (1 << 3), /* Basic block ends with a jump table */ BB_BEGINCATCH = (1 << 4), /* Block ends with a 'beginCatch' instruction, * marking it as the start of a 'catch' @@ -137,7 +134,7 @@ typedef enum { * converted to appropriate exception * ranges */ ASSEM_BOOL, /* One Boolean operand */ - ASSEM_BOOL_LVT4, /* One Boolean, one 4-byte LVT ref. */ + ASSEM_BOOL_LVT, /* One Boolean, one 4-byte LVT ref. */ ASSEM_CLOCK_READ, /* 1-byte unsigned-integer case number, in the * range 0-3 */ ASSEM_CONCAT1, /* 1-byte unsigned-integer operand count, must @@ -159,7 +156,6 @@ typedef enum { * strictly positive, consumes N, produces * 1. */ ASSEM_JUMP, /* Jump instructions */ - ASSEM_JUMP4, /* Jump instructions forcing a 4-byte offset */ ASSEM_JUMPTABLE, /* Jumptable (switch -exact) */ ASSEM_LABEL, /* The assembly directive that defines a * label */ @@ -169,14 +165,12 @@ typedef enum { * consumses N, produces 1 */ ASSEM_LSET_FLAT, /* 4-byte operand count, must be >= 3, * consumes N, produces 1 */ - ASSEM_LVT, /* One operand that references a local - * variable */ - ASSEM_LVT1, /* One 1-byte operand that references a local - * variable */ - ASSEM_LVT1_SINT1, /* One 1-byte operand that references a local + ASSEM_LVT_N, /* One 4-byte operand that references a local + * variable; doesn't update block start line */ + ASSEM_LVT_SINT1, /* One 4-byte operand that references a local * variable, one signed-integer 1-byte * operand */ - ASSEM_LVT4, /* One 4-byte operand that references a local + ASSEM_LVT, /* One 4-byte operand that references a local * variable */ ASSEM_OVER, /* OVER: 4-byte operand count, consumes N+1, * produces N+2 */ @@ -187,7 +181,7 @@ typedef enum { * produces N */ ASSEM_SINT1, /* One 1-byte signed-integer operand * (INCR_STK_IMM) */ - ASSEM_SINT4_LVT4, /* Signed 4-byte integer operand followed by + ASSEM_SINT4_LVT, /* Signed 4-byte integer operand followed by * LVT entry. Fixed arity */ ASSEM_DICT_GET_DEF /* 'dict getwithdefault' - consumes N+2 * operands, produces 1, N > 0 */ @@ -222,9 +216,9 @@ typedef struct AssemblyEnv { Tcl_HashTable labelHash; /* Hash table whose keys are labels and whose * values are 'label' objects storing the code * offsets of the labels. */ - Tcl_Size cmdLine; /* Current line number within the assembly + int cmdLine; /* Current line number within the assembly * code */ - Tcl_Size* clNext; /* Invisible continuation line for + Tcl_Size* clNext; /* Invisible continuation line for * [info frame] */ BasicBlock* head_bb; /* First basic block in the code */ BasicBlock* curr_bb; /* Current basic block */ @@ -250,34 +244,35 @@ static void BBEmitInstInt1(AssemblyEnv* assemEnvPtr, int tblIdx, int opnd, int count); static void BBEmitInstInt4(AssemblyEnv* assemEnvPtr, int tblIdx, int opnd, int count); -static void BBEmitInst1or4(AssemblyEnv* assemEnvPtr, int tblIdx, - int param, int count); static void BBEmitOpcode(AssemblyEnv* assemEnvPtr, int tblIdx, int count); static int BuildExceptionRanges(AssemblyEnv* assemEnvPtr); -static int CalculateJumpRelocations(AssemblyEnv*, int*); +static int ValidateJumpTargets(AssemblyEnv*); static int CheckForUnclosedCatches(AssemblyEnv*); static int CheckForThrowInWrongContext(AssemblyEnv*); static int CheckNonThrowingBlock(AssemblyEnv*, BasicBlock*); static int BytecodeMightThrow(unsigned char); static int CheckJumpTableLabels(AssemblyEnv*, BasicBlock*); static int CheckNamespaceQualifiers(Tcl_Interp*, const char*, - int); -static int CheckNonNegative(Tcl_Interp*, int); -static int CheckOneByte(Tcl_Interp*, int); -static int CheckSignedOneByte(Tcl_Interp*, int); + Tcl_Size); +static int CheckNonNegative(Tcl_Interp*, Tcl_Size); +static int CheckOneByte(Tcl_Interp*, Tcl_Size); +static int CheckSignedOneByte(Tcl_Interp*, Tcl_Size); static int CheckStack(AssemblyEnv*); -static int CheckStrictlyPositive(Tcl_Interp*, int); +static int CheckStrictlyPositive(Tcl_Interp*, Tcl_Size); static ByteCode * CompileAssembleObj(Tcl_Interp *interp, Tcl_Obj *objPtr); static void CompileEmbeddedScript(AssemblyEnv*, Tcl_Token*, const TalInstDesc*); static int DefineLabel(AssemblyEnv* envPtr, const char* label); -static void DeleteMirrorJumpTable(JumptableInfo* jtPtr); +static void DeleteMirrorJumpTable(JumptableInfo* jtPtr, + JumptableNumInfo* jtnPtr); static void FillInJumpOffsets(AssemblyEnv*); static int CreateMirrorJumpTable(AssemblyEnv* assemEnvPtr, - Tcl_Obj* jumpTable); -static size_t FindLocalVar(AssemblyEnv* envPtr, + Tcl_Size objc, Tcl_Obj** objv); +static int CreateMirrorNumJumpTable(AssemblyEnv* assemEnvPtr, + Tcl_Size objc, Tcl_Obj** objv); +static size_t FindLocalVar(AssemblyEnv* envPtr, Tcl_Token** tokenPtrPtr); static int FinishAssembly(AssemblyEnv*); static void FreeAssemblyEnv(AssemblyEnv*); @@ -286,8 +281,7 @@ static int GetListIndexOperand(AssemblyEnv*, Tcl_Token**, int*); static int GetIntegerOperand(AssemblyEnv*, Tcl_Token**, int*); static int GetNextOperand(AssemblyEnv*, Tcl_Token**, Tcl_Obj**); static void LookForFreshCatches(BasicBlock*, BasicBlock**); -static void MoveCodeForJumps(AssemblyEnv*, int); -static void MoveExceptionRangesToBasicBlock(AssemblyEnv*, int); +static void MoveExceptionRangesToBasicBlock(AssemblyEnv*, Tcl_Size); static AssemblyEnv* NewAssemblyEnv(CompileEnv*, int); static int ProcessCatches(AssemblyEnv*); static int ProcessCatchesInBasicBlock(AssemblyEnv*, BasicBlock*, @@ -306,12 +300,12 @@ static int StackCheckBasicBlock(AssemblyEnv*, BasicBlock *, BasicBlock *, int); static int StackCheckExit(AssemblyEnv*); static void StackFreshCatches(AssemblyEnv*, BasicBlock*, int, - BasicBlock**, int*); + BasicBlock**, Tcl_Size*); static void SyncStackDepth(AssemblyEnv*); static int TclAssembleCode(CompileEnv* envPtr, const char* code, - int codeLen, int flags); + Tcl_Size codeLen, int flags); static void UnstackExpiredCatches(CompileEnv*, BasicBlock*, int, - BasicBlock**, int*); + BasicBlock**, Tcl_Size*); /* * Tcl_ObjType that describes bytecode emitted by the assembler. @@ -335,22 +329,19 @@ static const Tcl_ObjType assembleCodeType = { static const TalInstDesc TalInstructionTable[] = { /* PUSH must be first, see the code near the end of TclAssembleCode */ - {"push", ASSEM_PUSH, (INST_PUSH1<<8 - | INST_PUSH4), 0, 1}, + {"push", ASSEM_PUSH, INST_PUSH, 0, 1}, {"add", ASSEM_1BYTE, INST_ADD, 2, 1}, - {"append", ASSEM_LVT, (INST_APPEND_SCALAR1<<8 - | INST_APPEND_SCALAR4),1, 1}, - {"appendArray", ASSEM_LVT, (INST_APPEND_ARRAY1<<8 - | INST_APPEND_ARRAY4), 2, 1}, + {"append", ASSEM_LVT_N, INST_APPEND_SCALAR, 1, 1}, + {"appendArray", ASSEM_LVT_N, INST_APPEND_ARRAY, 2, 1}, {"appendArrayStk", ASSEM_1BYTE, INST_APPEND_ARRAY_STK, 3, 1}, {"appendStk", ASSEM_1BYTE, INST_APPEND_STK, 2, 1}, - {"arrayExistsImm", ASSEM_LVT4, INST_ARRAY_EXISTS_IMM, 0, 1}, + {"arrayExistsImm", ASSEM_LVT, INST_ARRAY_EXISTS_IMM, 0, 1}, {"arrayExistsStk", ASSEM_1BYTE, INST_ARRAY_EXISTS_STK, 1, 1}, - {"arrayMakeImm", ASSEM_LVT4, INST_ARRAY_MAKE_IMM, 0, 0}, + {"arrayMakeImm", ASSEM_LVT, INST_ARRAY_MAKE_IMM, 0, 0}, {"arrayMakeStk", ASSEM_1BYTE, INST_ARRAY_MAKE_STK, 1, 0}, {"beginCatch", ASSEM_BEGIN_CATCH, - INST_BEGIN_CATCH4, 0, 0}, + INST_BEGIN_CATCH, 0, 0}, {"bitand", ASSEM_1BYTE, INST_BITAND, 2, 1}, {"bitnot", ASSEM_1BYTE, INST_BITNOT, 1, 1}, {"bitor", ASSEM_1BYTE, INST_BITOR, 2, 1}, @@ -360,16 +351,17 @@ static const TalInstDesc TalInstructionTable[] = { {"concatStk", ASSEM_LIST, INST_CONCAT_STK, INT_MIN,1}, {"coroName", ASSEM_1BYTE, INST_COROUTINE_NAME, 0, 1}, {"currentNamespace",ASSEM_1BYTE, INST_NS_CURRENT, 0, 1}, - {"dictAppend", ASSEM_LVT4, INST_DICT_APPEND, 2, 1}, + {"dictAppend", ASSEM_LVT, INST_DICT_APPEND, 2, 1}, {"dictExists", ASSEM_DICT_GET, INST_DICT_EXISTS, INT_MIN,1}, {"dictExpand", ASSEM_1BYTE, INST_DICT_EXPAND, 3, 1}, {"dictGet", ASSEM_DICT_GET, INST_DICT_GET, INT_MIN,1}, {"dictGetDef", ASSEM_DICT_GET_DEF, INST_DICT_GET_DEF, INT_MIN,1}, - {"dictIncrImm", ASSEM_SINT4_LVT4, - INST_DICT_INCR_IMM, 1, 1}, - {"dictLappend", ASSEM_LVT4, INST_DICT_LAPPEND, 2, 1}, + {"dictIncrImm", ASSEM_SINT4_LVT,INST_DICT_INCR_IMM, 1, 1}, + {"dictLappend", ASSEM_LVT, INST_DICT_LAPPEND, 2, 1}, + {"dictPut", ASSEM_1BYTE, INST_DICT_PUT, 3, 1}, {"dictRecombineStk",ASSEM_1BYTE, INST_DICT_RECOMBINE_STK,3, 0}, - {"dictRecombineImm",ASSEM_LVT4, INST_DICT_RECOMBINE_IMM,2, 0}, + {"dictRecombineImm",ASSEM_LVT, INST_DICT_RECOMBINE_IMM,2, 0}, + {"dictRemove", ASSEM_1BYTE, INST_DICT_REMOVE, 2, 1}, {"dictSet", ASSEM_DICT_SET, INST_DICT_SET, INT_MIN,1}, {"dictUnset", ASSEM_DICT_UNSET, INST_DICT_UNSET, INT_MIN,1}, @@ -379,8 +371,8 @@ static const TalInstDesc TalInstructionTable[] = { {"eq", ASSEM_1BYTE, INST_EQ, 2, 1}, {"eval", ASSEM_EVAL, INST_EVAL_STK, 1, 1}, {"evalStk", ASSEM_1BYTE, INST_EVAL_STK, 1, 1}, - {"exist", ASSEM_LVT4, INST_EXIST_SCALAR, 0, 1}, - {"existArray", ASSEM_LVT4, INST_EXIST_ARRAY, 1, 1}, + {"exist", ASSEM_LVT, INST_EXIST_SCALAR, 0, 1}, + {"existArray", ASSEM_LVT, INST_EXIST_ARRAY, 1, 1}, {"existArrayStk", ASSEM_1BYTE, INST_EXIST_ARRAY_STK, 2, 1}, {"existStk", ASSEM_1BYTE, INST_EXIST_STK, 1, 1}, {"expon", ASSEM_1BYTE, INST_EXPON, 2, 1}, @@ -388,36 +380,35 @@ static const TalInstDesc TalInstructionTable[] = { {"exprStk", ASSEM_1BYTE, INST_EXPR_STK, 1, 1}, {"ge", ASSEM_1BYTE, INST_GE, 2, 1}, {"gt", ASSEM_1BYTE, INST_GT, 2, 1}, - {"incr", ASSEM_LVT1, INST_INCR_SCALAR1, 1, 1}, - {"incrArray", ASSEM_LVT1, INST_INCR_ARRAY1, 2, 1}, - {"incrArrayImm", ASSEM_LVT1_SINT1, - INST_INCR_ARRAY1_IMM, 1, 1}, + {"incr", ASSEM_LVT, INST_INCR_SCALAR, 1, 1}, + {"incrArray", ASSEM_LVT, INST_INCR_ARRAY, 2, 1}, + {"incrArrayImm", ASSEM_LVT_SINT1,INST_INCR_ARRAY_IMM, 1, 1}, {"incrArrayStk", ASSEM_1BYTE, INST_INCR_ARRAY_STK, 3, 1}, {"incrArrayStkImm", ASSEM_SINT1, INST_INCR_ARRAY_STK_IMM,2, 1}, - {"incrImm", ASSEM_LVT1_SINT1, - INST_INCR_SCALAR1_IMM, 0, 1}, + {"incrImm", ASSEM_LVT_SINT1,INST_INCR_SCALAR_IMM, 0, 1}, {"incrStk", ASSEM_1BYTE, INST_INCR_STK, 2, 1}, {"incrStkImm", ASSEM_SINT1, INST_INCR_STK_IMM, 1, 1}, {"infoLevelArgs", ASSEM_1BYTE, INST_INFO_LEVEL_ARGS, 1, 1}, {"infoLevelNumber", ASSEM_1BYTE, INST_INFO_LEVEL_NUM, 0, 1}, - {"invokeStk", ASSEM_INVOKE, (INST_INVOKE_STK1 << 8 - | INST_INVOKE_STK4), INT_MIN,1}, - {"jump", ASSEM_JUMP, INST_JUMP1, 0, 0}, - {"jump4", ASSEM_JUMP4, INST_JUMP4, 0, 0}, - {"jumpFalse", ASSEM_JUMP, INST_JUMP_FALSE1, 1, 0}, - {"jumpFalse4", ASSEM_JUMP4, INST_JUMP_FALSE4, 1, 0}, + {"invokeStk", ASSEM_INVOKE, INST_INVOKE_STK, INT_MIN,1}, + {"isEmpty", ASSEM_1BYTE, INST_IS_EMPTY, 1, 1}, + {"jump", ASSEM_JUMP, INST_JUMP, 0, 0}, + // For legacy code + {"jump4", ASSEM_JUMP, INST_JUMP, 0, 0}, + {"jumpFalse", ASSEM_JUMP, INST_JUMP_FALSE, 1, 0}, + // For legacy code + {"jumpFalse4", ASSEM_JUMP, INST_JUMP_FALSE, 1, 0}, {"jumpTable", ASSEM_JUMPTABLE,INST_JUMP_TABLE, 1, 0}, - {"jumpTrue", ASSEM_JUMP, INST_JUMP_TRUE1, 1, 0}, - {"jumpTrue4", ASSEM_JUMP4, INST_JUMP_TRUE4, 1, 0}, + {"jumpTableNum", ASSEM_JUMPTABLE,INST_JUMP_TABLE_NUM, 1, 0}, + {"jumpTrue", ASSEM_JUMP, INST_JUMP_TRUE, 1, 0}, + // For legacy code + {"jumpTrue4", ASSEM_JUMP, INST_JUMP_TRUE, 1, 0}, {"label", ASSEM_LABEL, 0, 0, 0}, - {"lappend", ASSEM_LVT, (INST_LAPPEND_SCALAR1<<8 - | INST_LAPPEND_SCALAR4), - 1, 1}, - {"lappendArray", ASSEM_LVT, (INST_LAPPEND_ARRAY1<<8 - | INST_LAPPEND_ARRAY4),2, 1}, + {"lappend", ASSEM_LVT_N, INST_LAPPEND_SCALAR, 1, 1}, + {"lappendArray", ASSEM_LVT_N, INST_LAPPEND_ARRAY, 2, 1}, {"lappendArrayStk", ASSEM_1BYTE, INST_LAPPEND_ARRAY_STK, 3, 1}, - {"lappendList", ASSEM_LVT4, INST_LAPPEND_LIST, 1, 1}, - {"lappendListArray",ASSEM_LVT4, INST_LAPPEND_LIST_ARRAY,2, 1}, + {"lappendList", ASSEM_LVT, INST_LAPPEND_LIST, 1, 1}, + {"lappendListArray",ASSEM_LVT, INST_LAPPEND_LIST_ARRAY,2, 1}, {"lappendListArrayStk", ASSEM_1BYTE,INST_LAPPEND_LIST_ARRAY_STK, 3, 1}, {"lappendListStk", ASSEM_1BYTE, INST_LAPPEND_LIST_STK, 2, 1}, {"lappendStk", ASSEM_1BYTE, INST_LAPPEND_STK, 2, 1}, @@ -431,10 +422,8 @@ static const TalInstDesc TalInstructionTable[] = { {"listIndexImm", ASSEM_INDEX, INST_LIST_INDEX_IMM, 1, 1}, {"listLength", ASSEM_1BYTE, INST_LIST_LENGTH, 1, 1}, {"listNotIn", ASSEM_1BYTE, INST_LIST_NOT_IN, 2, 1}, - {"load", ASSEM_LVT, (INST_LOAD_SCALAR1 << 8 - | INST_LOAD_SCALAR4), 0, 1}, - {"loadArray", ASSEM_LVT, (INST_LOAD_ARRAY1<<8 - | INST_LOAD_ARRAY4), 1, 1}, + {"load", ASSEM_LVT_N, INST_LOAD_SCALAR, 0, 1}, + {"loadArray", ASSEM_LVT_N, INST_LOAD_ARRAY, 1, 1}, {"loadArrayStk", ASSEM_1BYTE, INST_LOAD_ARRAY_STK, 2, 1}, {"loadStk", ASSEM_1BYTE, INST_LOAD_STK, 1, 1}, {"lsetFlat", ASSEM_LSET_FLAT,INST_LSET_FLAT, INT_MIN,1}, @@ -446,7 +435,7 @@ static const TalInstDesc TalInstructionTable[] = { {"neq", ASSEM_1BYTE, INST_NEQ, 2, 1}, {"nop", ASSEM_1BYTE, INST_NOP, 0, 0}, {"not", ASSEM_1BYTE, INST_LNOT, 1, 1}, - {"nsupvar", ASSEM_LVT4, INST_NSUPVAR, 2, 1}, + {"nsupvar", ASSEM_LVT, INST_NSUPVAR, 2, 1}, {"numericType", ASSEM_1BYTE, INST_NUM_TYPE, 1, 1}, {"originCmd", ASSEM_1BYTE, INST_ORIGIN_COMMAND, 1, 1}, {"over", ASSEM_OVER, INST_OVER, INT_MIN,-1-1}, @@ -459,10 +448,8 @@ static const TalInstDesc TalInstructionTable[] = { {"resolveCmd", ASSEM_1BYTE, INST_RESOLVE_COMMAND, 1, 1}, {"reverse", ASSEM_REVERSE, INST_REVERSE, INT_MIN,-1-0}, {"rshift", ASSEM_1BYTE, INST_RSHIFT, 2, 1}, - {"store", ASSEM_LVT, (INST_STORE_SCALAR1<<8 - | INST_STORE_SCALAR4), 1, 1}, - {"storeArray", ASSEM_LVT, (INST_STORE_ARRAY1<<8 - | INST_STORE_ARRAY4), 2, 1}, + {"store", ASSEM_LVT_N, INST_STORE_SCALAR, 1, 1}, + {"storeArray", ASSEM_LVT_N, INST_STORE_ARRAY, 2, 1}, {"storeArrayStk", ASSEM_1BYTE, INST_STORE_ARRAY_STK, 3, 1}, {"storeStk", ASSEM_1BYTE, INST_STORE_STK, 2, 1}, {"strcaseLower", ASSEM_1BYTE, INST_STR_LOWER, 1, 1}, @@ -488,23 +475,25 @@ static const TalInstDesc TalInstructionTable[] = { {"strtrimLeft", ASSEM_1BYTE, INST_STR_TRIM_LEFT, 2, 1}, {"strtrimRight", ASSEM_1BYTE, INST_STR_TRIM_RIGHT, 2, 1}, {"sub", ASSEM_1BYTE, INST_SUB, 2, 1}, + {"swap", ASSEM_1BYTE, INST_SWAP, 2, 2}, {"tclooClass", ASSEM_1BYTE, INST_TCLOO_CLASS, 1, 1}, + {"tclooId", ASSEM_1BYTE, INST_TCLOO_ID, 1, 1}, {"tclooIsObject", ASSEM_1BYTE, INST_TCLOO_IS_OBJECT, 1, 1}, {"tclooNamespace", ASSEM_1BYTE, INST_TCLOO_NS, 1, 1}, {"tclooSelf", ASSEM_1BYTE, INST_TCLOO_SELF, 0, 1}, {"tryCvtToBoolean", ASSEM_1BYTE, INST_TRY_CVT_TO_BOOLEAN,1, 2}, {"tryCvtToNumeric", ASSEM_1BYTE, INST_TRY_CVT_TO_NUMERIC,1, 1}, {"uminus", ASSEM_1BYTE, INST_UMINUS, 1, 1}, - {"unset", ASSEM_BOOL_LVT4,INST_UNSET_SCALAR, 0, 0}, - {"unsetArray", ASSEM_BOOL_LVT4,INST_UNSET_ARRAY, 1, 0}, + {"unset", ASSEM_BOOL_LVT, INST_UNSET_SCALAR, 0, 0}, + {"unsetArray", ASSEM_BOOL_LVT, INST_UNSET_ARRAY, 1, 0}, {"unsetArrayStk", ASSEM_BOOL, INST_UNSET_ARRAY_STK, 2, 0}, {"unsetStk", ASSEM_BOOL, INST_UNSET_STK, 1, 0}, {"uplus", ASSEM_1BYTE, INST_UPLUS, 1, 1}, - {"upvar", ASSEM_LVT4, INST_UPVAR, 2, 1}, - {"variable", ASSEM_LVT4, INST_VARIABLE, 1, 0}, + {"upvar", ASSEM_LVT, INST_UPVAR, 2, 1}, + {"variable", ASSEM_LVT, INST_VARIABLE, 1, 0}, {"verifyDict", ASSEM_1BYTE, INST_DICT_VERIFY, 1, 0}, {"yield", ASSEM_1BYTE, INST_YIELD, 1, 1}, - {NULL, ASSEM_1BYTE, 0, 0, 0} + {NULL, ASSEM_1BYTE, 0, 0, 0} }; /* @@ -516,26 +505,26 @@ static const TalInstDesc TalInstructionTable[] = { */ static const unsigned char NonThrowingByteCodes[] = { - INST_PUSH1, INST_PUSH4, INST_POP, INST_DUP, /* 1-4 */ - INST_JUMP1, INST_JUMP4, /* 34-35 */ - INST_END_CATCH, INST_PUSH_RESULT, INST_PUSH_RETURN_CODE, /* 70-72 */ - INST_STR_EQ, INST_STR_NEQ, INST_STR_CMP, INST_STR_LEN, /* 73-76 */ - INST_LIST, /* 79 */ - INST_OVER, /* 95 */ - INST_PUSH_RETURN_OPTIONS, /* 108 */ - INST_REVERSE, /* 126 */ - INST_NOP, /* 132 */ - INST_STR_MAP, /* 143 */ - INST_STR_FIND, /* 144 */ - INST_COROUTINE_NAME, /* 149 */ - INST_NS_CURRENT, /* 151 */ - INST_INFO_LEVEL_NUM, /* 152 */ - INST_RESOLVE_COMMAND, /* 154 */ - INST_STR_TRIM, INST_STR_TRIM_LEFT, INST_STR_TRIM_RIGHT, /* 166-168 */ - INST_CONCAT_STK, /* 169 */ - INST_STR_UPPER, INST_STR_LOWER, INST_STR_TITLE, /* 170-172 */ - INST_NUM_TYPE, /* 180 */ - INST_STR_LT, INST_STR_GT, INST_STR_LE, INST_STR_GE /* 191-194 */ + INST_PUSH, INST_POP, INST_DUP, /* 2-4 */ + INST_JUMP, /* 35 */ + INST_END_CATCH, INST_PUSH_RESULT, INST_PUSH_RETURN_CODE, /* 64-66 */ + INST_STR_EQ, INST_STR_NEQ, INST_STR_CMP, INST_STR_LEN, /* 67-70 */ + INST_LIST, /* 73 */ + INST_OVER, /* 89 */ + INST_PUSH_RETURN_OPTIONS, /* 102 */ + INST_REVERSE, /* 119 */ + INST_NOP, /* 125 */ + INST_STR_MAP, INST_STR_FIND, INST_STR_FIND_LAST, /* 136-138 */ + INST_COROUTINE_NAME, /* 142 */ + INST_NS_CURRENT, INST_INFO_LEVEL_NUM, /* 144-145 */ + INST_RESOLVE_COMMAND, /* 147 */ + INST_STR_TRIM, INST_STR_TRIM_LEFT, INST_STR_TRIM_RIGHT, /* 163-165 */ + INST_CONCAT_STK, /* 166 */ + INST_STR_UPPER, INST_STR_LOWER, INST_STR_TITLE, /* 167-169 */ + INST_NUM_TYPE, /* 175 */ + INST_STR_LT, INST_STR_GT, INST_STR_LE, INST_STR_GE, /* 184-187 */ + INST_SWAP, /* 199 */ + INST_IS_EMPTY /* 204 */ }; /* @@ -682,8 +671,20 @@ BBEmitOpcode( * number. */ - if (bbPtr->startOffset == envPtr->codeNext - envPtr->codeStart) { - bbPtr->startLine = assemEnvPtr->cmdLine; + if (bbPtr->startOffset == CurrentOffset(envPtr)) { + switch (TalInstructionTable[tblIdx].instType) { + case ASSEM_LVT_N: + case ASSEM_PUSH: + case ASSEM_INVOKE: + case ASSEM_JUMP: + /* + * Note that we suppress this for some instruction types. + * Not sure why, but it makes tests pass. + */ + break; + default: + bbPtr->startLine = assemEnvPtr->cmdLine; + } } TclEmitInt1(op, envPtr); @@ -716,45 +717,6 @@ BBEmitInstInt4( /* *----------------------------------------------------------------------------- * - * BBEmitInst1or4 -- - * - * Emits a 1- or 4-byte operation according to the magnitude of the - * operand. - * - *----------------------------------------------------------------------------- - */ - -static void -BBEmitInst1or4( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - int tblIdx, /* Index in TalInstructionTable of op */ - int param, /* Variable-length parameter */ - int count) /* Arity if variadic */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - BasicBlock* bbPtr = assemEnvPtr->curr_bb; - /* Current basic block */ - int op = TalInstructionTable[tblIdx].tclInstCode; - - if (param <= 0xFF) { - op >>= 8; - } else { - op &= 0xFF; - } - TclEmitInt1(op, envPtr); - if (param <= 0xFF) { - TclEmitInt1(param, envPtr); - } else { - TclEmitInt4(param, envPtr); - } - TclUpdateAtCmdStart(op, envPtr); - BBUpdateStackReqs(bbPtr, tblIdx, count); -} - -/* - *----------------------------------------------------------------------------- - * * Tcl_AssembleObjCmd, TclNRAssembleObjCmd -- * * Direct evaluation path for tcl::unsupported::assemble @@ -781,7 +743,8 @@ Tcl_AssembleObjCmd( * because there needs to be one in place to execute bytecode. */ - return Tcl_NRCallObjProc(interp, TclNRAssembleObjCmd, clientData, objc, objv); + return Tcl_NRCallObjProc(interp, TclNRAssembleObjCmd, clientData, + objc, objv); } int @@ -792,8 +755,6 @@ TclNRAssembleObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { ByteCode *codePtr; /* Pointer to the bytecode to execute */ - Tcl_Obj* backtrace; /* Object where extra error information is - * constructed. */ if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "bytecodeList"); @@ -811,12 +772,9 @@ TclNRAssembleObjCmd( */ if (codePtr == NULL) { - Tcl_AddErrorInfo(interp, "\n (\""); - Tcl_AppendObjToErrorInfo(interp, objv[0]); - Tcl_AddErrorInfo(interp, "\" body, line "); - TclNewIntObj(backtrace, Tcl_GetErrorLine(interp)); - Tcl_AppendObjToErrorInfo(interp, backtrace); - Tcl_AddErrorInfo(interp, ")"); + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (\"%s\" body, line %d)", + Tcl_GetString(objv[0]), Tcl_GetErrorLine(interp))); return TCL_ERROR; } @@ -958,10 +916,13 @@ TclCompileAssembleCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *tokenPtr; /* Token in the input script */ + Tcl_Size numCommands = envPtr->numCommands; + Tcl_Size offset = CurrentOffset(envPtr); + Tcl_Size depth = envPtr->currStackDepth; + Tcl_Size numExnRanges = envPtr->exceptArrayNext; + Tcl_Size numAuxRanges = envPtr->auxDataArrayNext; + Tcl_Size exceptDepth = envPtr->exceptDepth; - size_t numCommands = envPtr->numCommands; - int offset = envPtr->codeNext - envPtr->codeStart; - size_t depth = envPtr->currStackDepth; /* * Make sure that the command has a single arg that is a simple word. */ @@ -988,6 +949,17 @@ TclCompileAssembleCmd( envPtr->numCommands = numCommands; envPtr->codeNext = envPtr->codeStart + offset; envPtr->currStackDepth = depth; + envPtr->exceptArrayNext = numExnRanges; + while (envPtr->auxDataArrayNext > numAuxRanges) { + Tcl_Size auxIdx = --envPtr->auxDataArrayNext; + AuxData *auxDataPtr = &envPtr->auxDataArrayPtr[auxIdx]; + if (auxDataPtr->type && auxDataPtr->type->freeProc) { + auxDataPtr->type->freeProc(auxDataPtr->clientData); + } + auxDataPtr->clientData = NULL; + auxDataPtr->type = NULL; + } + envPtr->exceptDepth = exceptDepth; TclCompileSyntaxError(interp, envPtr); } return TCL_OK; @@ -1017,7 +989,7 @@ TclAssembleCode( CompileEnv *envPtr, /* Compilation environment that is to receive * the generated bytecode */ const char* codePtr, /* Assembly-language code to be processed */ - int codeLen, /* Length of the code */ + Tcl_Size codeLen, /* Length of the code */ int flags) /* OR'ed combination of flags */ { Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; @@ -1030,7 +1002,8 @@ TclAssembleCode( const char* instPtr = codePtr; /* Where to start looking for a line of code */ const char* nextPtr; /* Pointer to the end of the line of code */ - int bytesLeft = codeLen; /* Number of bytes of source code remaining to + Tcl_Size bytesLeft = codeLen; + /* Number of bytes of source code remaining to * be parsed */ int status; /* Tcl status return */ AssemblyEnv* assemEnvPtr = NewAssemblyEnv(envPtr, flags); @@ -1082,9 +1055,10 @@ TclAssembleCode( */ #ifdef TCL_COMPILE_DEBUG - if ((tclTraceCompile >= 2) && (envPtr->procPtr == NULL)) { + if ((tclTraceCompile >= TCL_TRACE_BYTECODE_COMPILE_DETAIL) + && !EnvIsProc(envPtr)) { printf(" %4" TCL_Z_MODIFIER "d Assembling: ", - envPtr->codeNext - envPtr->codeStart); + CurrentOffset(envPtr)); TclPrintSource(stdout, parsePtr->commandStart, TclMin(instLen, 55)); printf("\n"); @@ -1145,7 +1119,8 @@ NewAssemblyEnv( { Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; /* Tcl interpreter */ - AssemblyEnv* assemEnvPtr = (AssemblyEnv*)TclStackAlloc(interp, sizeof(AssemblyEnv)); + AssemblyEnv* assemEnvPtr = (AssemblyEnv*)TclStackAlloc(interp, + sizeof(AssemblyEnv)); /* Assembler environment under construction */ Tcl_Parse* parsePtr = (Tcl_Parse*)TclStackAlloc(interp, sizeof(Tcl_Parse)); /* Parse of one line of assembly code */ @@ -1213,9 +1188,10 @@ FreeAssemblyEnv( Tcl_Free(thisBB->foreignExceptions); } nextBB = thisBB->successor1; - if (thisBB->jtPtr != NULL) { - DeleteMirrorJumpTable(thisBB->jtPtr); + if (thisBB->jtPtr || thisBB->jtnPtr) { + DeleteMirrorJumpTable(thisBB->jtPtr, thisBB->jtnPtr); thisBB->jtPtr = NULL; + thisBB->jtnPtr = NULL; } Tcl_Free(thisBB); } @@ -1266,10 +1242,9 @@ AssembleOneLine( Tcl_Size operand1Len; /* String length of the operand */ int opnd; /* Integer representation of an operand */ int litIndex; /* Literal pool index of a constant */ - Tcl_Size localVar; /* LVT index of a local variable */ + Tcl_Size localVar; /* LVT index of a local variable */ int flags; /* Flags for a basic block */ - JumptableInfo* jtPtr; /* Pointer to a jumptable */ - int infoIndex; /* Index of the jumptable in auxdata */ + Tcl_Size infoIndex; /* Index of the jumptable in auxdata */ int status = TCL_ERROR; /* Return value from this function */ /* @@ -1308,7 +1283,7 @@ AssembleOneLine( } operand1 = TclGetStringFromObj(operand1Obj, &operand1Len); litIndex = TclRegisterLiteral(envPtr, operand1, operand1Len, 0); - BBEmitInst1or4(assemEnvPtr, tblIdx, litIndex, 0); + BBEmitInstInt4(assemEnvPtr, tblIdx, litIndex, 0); break; case ASSEM_1BYTE: @@ -1335,7 +1310,7 @@ AssembleOneLine( goto cleanup; } assemEnvPtr->curr_bb->jumpLine = assemEnvPtr->cmdLine; - assemEnvPtr->curr_bb->jumpOffset = envPtr->codeNext-envPtr->codeStart; + assemEnvPtr->curr_bb->jumpOffset = CurrentOffset(envPtr); BBEmitInstInt4(assemEnvPtr, tblIdx, 0, 0); assemEnvPtr->curr_bb->flags |= BB_BEGINCATCH; StartBasicBlock(assemEnvPtr, BB_FALLTHRU, operand1Obj); @@ -1352,7 +1327,7 @@ AssembleOneLine( BBEmitInstInt1(assemEnvPtr, tblIdx, opnd, 0); break; - case ASSEM_BOOL_LVT4: + case ASSEM_BOOL_LVT: if (parsePtr->numWords != 3) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "boolean varName"); goto cleanup; @@ -1377,8 +1352,8 @@ AssembleOneLine( goto cleanup; } if (opnd < 0 || opnd > 3) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("operand must be [0..3]", -1)); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "operand must be [0..3]", TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "ASSEM", "OPERAND<0,>3", (char *)NULL); goto cleanup; } @@ -1480,7 +1455,7 @@ AssembleOneLine( * Assumes that PUSH is the first slot! */ - BBEmitInst1or4(assemEnvPtr, 0, litIndex, 0); + BBEmitInstInt4(assemEnvPtr, 0, litIndex, 0); BBEmitOpcode(assemEnvPtr, tblIdx, 0); } break; @@ -1495,11 +1470,10 @@ AssembleOneLine( goto cleanup; } - BBEmitInst1or4(assemEnvPtr, tblIdx, opnd, opnd); + BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd); break; case ASSEM_JUMP: - case ASSEM_JUMP4: if (parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "label"); goto cleanup; @@ -1507,14 +1481,9 @@ AssembleOneLine( if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) { goto cleanup; } - assemEnvPtr->curr_bb->jumpOffset = envPtr->codeNext-envPtr->codeStart; - if (instType == ASSEM_JUMP) { - flags = BB_JUMP1; - BBEmitInstInt1(assemEnvPtr, tblIdx, 0, 0); - } else { - flags = 0; - BBEmitInstInt4(assemEnvPtr, tblIdx, 0, 0); - } + assemEnvPtr->curr_bb->jumpOffset = CurrentOffset(envPtr); + flags = 0; + BBEmitInstInt4(assemEnvPtr, tblIdx, 0, 0); /* * Start a new basic block at the instruction following the jump. @@ -1527,7 +1496,10 @@ AssembleOneLine( StartBasicBlock(assemEnvPtr, flags, operand1Obj); break; - case ASSEM_JUMPTABLE: + case ASSEM_JUMPTABLE: { + Tcl_Size jtObjc; + Tcl_Obj **jtObjv; + if (parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "table"); goto cleanup; @@ -1535,25 +1507,54 @@ AssembleOneLine( if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) { goto cleanup; } + if (TclListObjGetElements(interp, operand1Obj, &jtObjc, &jtObjv) != TCL_OK) { + goto cleanup; + } + if (jtObjc % 2 != 0) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "jump table must have an even number of list elements", + TCL_AUTO_LENGTH)); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADJUMPTABLE", (char *)NULL); + goto cleanup; + } - jtPtr = (JumptableInfo*)Tcl_Alloc(sizeof(JumptableInfo)); + if (TalInstructionTable[tblIdx].tclInstCode == INST_JUMP_TABLE) { + JumptableInfo* jtPtr = AllocJumptable(); - Tcl_InitHashTable(&jtPtr->hashTable, TCL_STRING_KEYS); - assemEnvPtr->curr_bb->jumpLine = assemEnvPtr->cmdLine; - assemEnvPtr->curr_bb->jumpOffset = envPtr->codeNext-envPtr->codeStart; - DEBUG_PRINT("bb %p jumpLine %d jumpOffset %d\n", - assemEnvPtr->curr_bb, assemEnvPtr->cmdLine, - envPtr->codeNext - envPtr->codeStart); + assemEnvPtr->curr_bb->jumpLine = assemEnvPtr->cmdLine; + assemEnvPtr->curr_bb->jumpOffset = CurrentOffset(envPtr); + DEBUG_PRINT("bb %p jumpLine %d jumpOffset %d\n", + assemEnvPtr->curr_bb, assemEnvPtr->cmdLine, + CurrentOffset(envPtr)); - infoIndex = TclCreateAuxData(jtPtr, &tclJumptableInfoType, envPtr); - DEBUG_PRINT("auxdata index=%d\n", infoIndex); + infoIndex = RegisterJumptable(jtPtr, envPtr); + DEBUG_PRINT("auxdata index=%d\n", infoIndex); - BBEmitInstInt4(assemEnvPtr, tblIdx, infoIndex, 0); - if (CreateMirrorJumpTable(assemEnvPtr, operand1Obj) != TCL_OK) { - goto cleanup; + BBEmitInstInt4(assemEnvPtr, tblIdx, infoIndex, 0); + if (CreateMirrorJumpTable(assemEnvPtr, jtObjc, jtObjv) != TCL_OK) { + goto cleanup; + } + } else { + JumptableNumInfo* jtnPtr = AllocJumptableNum(); + + assert(TalInstructionTable[tblIdx].tclInstCode == INST_JUMP_TABLE_NUM); + assemEnvPtr->curr_bb->jumpLine = assemEnvPtr->cmdLine; + assemEnvPtr->curr_bb->jumpOffset = CurrentOffset(envPtr); + DEBUG_PRINT("bb %p jumpLine %d jumpOffset %d\n", + assemEnvPtr->curr_bb, assemEnvPtr->cmdLine, + CurrentOffset(envPtr)); + + infoIndex = RegisterJumptableNum(jtnPtr, envPtr); + DEBUG_PRINT("auxdata index=%d\n", infoIndex); + + BBEmitInstInt4(assemEnvPtr, tblIdx, infoIndex, 0); + if (CreateMirrorNumJumpTable(assemEnvPtr, jtObjc, jtObjv) != TCL_OK) { + goto cleanup; + } } StartBasicBlock(assemEnvPtr, BB_JUMPTABLE|BB_FALLTHRU, NULL); break; + } case ASSEM_LABEL: if (parsePtr->numWords != 2) { @@ -1618,8 +1619,8 @@ AssembleOneLine( } if (opnd < 2) { if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("operand must be >=2", -1)); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "operand must be >=2", TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "ASSEM", "OPERAND>=2", (char *)NULL); } goto cleanup; @@ -1627,48 +1628,25 @@ AssembleOneLine( BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd); break; - case ASSEM_LVT: - if (parsePtr->numWords != 2) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "varname"); - goto cleanup; - } - localVar = FindLocalVar(assemEnvPtr, &tokenPtr); - if (localVar < 0) { - goto cleanup; - } - BBEmitInst1or4(assemEnvPtr, tblIdx, localVar, 0); - break; - - case ASSEM_LVT1: - if (parsePtr->numWords != 2) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "varname"); - goto cleanup; - } - localVar = FindLocalVar(assemEnvPtr, &tokenPtr); - if (localVar < 0 || CheckOneByte(interp, localVar)) { - goto cleanup; - } - BBEmitInstInt1(assemEnvPtr, tblIdx, localVar, 0); - break; - - case ASSEM_LVT1_SINT1: + case ASSEM_LVT_SINT1: if (parsePtr->numWords != 3) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "varName imm8"); goto cleanup; } localVar = FindLocalVar(assemEnvPtr, &tokenPtr); - if (localVar < 0 || CheckOneByte(interp, localVar) + if (localVar < 0 || GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK || CheckSignedOneByte(interp, opnd)) { goto cleanup; } - BBEmitInstInt1(assemEnvPtr, tblIdx, localVar, 0); + BBEmitInstInt4(assemEnvPtr, tblIdx, localVar, 0); TclEmitInt1(opnd, envPtr); break; - case ASSEM_LVT4: + case ASSEM_LVT_N: + case ASSEM_LVT: if (parsePtr->numWords != 2) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "varname"); + Tcl_WrongNumArgs(interp, 1, &instNameObj, "varName"); goto cleanup; } localVar = FindLocalVar(assemEnvPtr, &tokenPtr); @@ -1698,9 +1676,8 @@ AssembleOneLine( if (GetBooleanOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) { goto cleanup; } - { - BBEmitInstInt1(assemEnvPtr, tblIdx, TCL_REG_ADVANCED | (opnd ? TCL_REG_NOCASE : 0), 0); - } + BBEmitInstInt1(assemEnvPtr, tblIdx, + TCL_REG_ADVANCED | (opnd ? TCL_REG_NOCASE : 0), 0); break; case ASSEM_REVERSE: @@ -1727,7 +1704,7 @@ AssembleOneLine( BBEmitInstInt1(assemEnvPtr, tblIdx, opnd, 0); break; - case ASSEM_SINT4_LVT4: + case ASSEM_SINT4_LVT: if (parsePtr->numWords != 3) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "count varName"); goto cleanup; @@ -1749,7 +1726,7 @@ AssembleOneLine( } status = TCL_OK; - cleanup: + cleanup: Tcl_DecrRefCount(instNameObj); if (operand1Obj) { Tcl_DecrRefCount(operand1Obj); @@ -1808,7 +1785,7 @@ CompileEmbeddedScript( size_t savedStackDepth = envPtr->currStackDepth; size_t savedMaxStackDepth = envPtr->maxStackDepth; - int savedExceptArrayNext = envPtr->exceptArrayNext; + Tcl_Size savedExceptArrayNext = envPtr->exceptArrayNext; envPtr->currStackDepth = 0; envPtr->maxStackDepth = 0; @@ -1874,7 +1851,7 @@ SyncStackDepth( /* Compilation environment */ BasicBlock* curr_bb = assemEnvPtr->curr_bb; /* Current basic block */ - int maxStackDepth = curr_bb->finalStackDepth + envPtr->maxStackDepth; + Tcl_Size maxStackDepth = curr_bb->finalStackDepth + envPtr->maxStackDepth; /* Max stack depth in the basic block */ if (maxStackDepth > curr_bb->maxStackDepth) { @@ -1899,16 +1876,17 @@ SyncStackDepth( static void MoveExceptionRangesToBasicBlock( AssemblyEnv* assemEnvPtr, /* Assembly environment */ - int savedExceptArrayNext) /* Saved index of the end of the exception + Tcl_Size savedExceptArrayNext) + /* Saved index of the end of the exception * range array */ { CompileEnv* envPtr = assemEnvPtr->envPtr; /* Compilation environment */ BasicBlock* curr_bb = assemEnvPtr->curr_bb; /* Current basic block */ - int exceptionCount = envPtr->exceptArrayNext - savedExceptArrayNext; + Tcl_Size exceptionCount = envPtr->exceptArrayNext - savedExceptArrayNext; /* Number of ranges that must be moved */ - int i; + Tcl_Size i; if (exceptionCount == 0) { /* Nothing to do */ @@ -1929,8 +1907,8 @@ MoveExceptionRangesToBasicBlock( curr_bb, exceptionCount, savedExceptArrayNext); curr_bb->foreignExceptionBase = savedExceptArrayNext; curr_bb->foreignExceptionCount = exceptionCount; - curr_bb->foreignExceptions = - (ExceptionRange*)Tcl_Alloc(exceptionCount * sizeof(ExceptionRange)); + curr_bb->foreignExceptions = (ExceptionRange*) + Tcl_Alloc(exceptionCount * sizeof(ExceptionRange)); memcpy(curr_bb->foreignExceptions, envPtr->exceptArrayPtr + savedExceptArrayNext, exceptionCount * sizeof(ExceptionRange)); @@ -1961,10 +1939,9 @@ MoveExceptionRangesToBasicBlock( static int CreateMirrorJumpTable( AssemblyEnv* assemEnvPtr, /* Assembly environment */ - Tcl_Obj* jumps) /* List of alternating keywords and labels */ + Tcl_Size objc, /* Number of elements in the 'jumps' list */ + Tcl_Obj** objv) /* Pointers to the elements in the list */ { - Tcl_Size objc; /* Number of elements in the 'jumps' list */ - Tcl_Obj** objv; /* Pointers to the elements in the list */ CompileEnv* envPtr = assemEnvPtr->envPtr; /* Compilation environment */ Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; @@ -1972,35 +1949,94 @@ CreateMirrorJumpTable( BasicBlock* bbPtr = assemEnvPtr->curr_bb; /* Current basic block */ JumptableInfo* jtPtr; - Tcl_HashTable* jtHashPtr; /* Hashtable in the JumptableInfo */ - Tcl_HashEntry* hashEntry; /* Entry for a key in the hashtable */ + Tcl_HashEntry* hPtr; /* Entry for a key in the hashtable */ int isNew; /* Flag==1 if the key is not yet in the * table. */ Tcl_Size i; - if (TclListObjLength(interp, jumps, &objc) != TCL_OK) { - return TCL_ERROR; - } - if (objc % 2 != 0) { - if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "jump table must have an even number of list elements", - -1)); - Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADJUMPTABLE", (char *)NULL); + /* + * Allocate the jumptable. Don't write to BB until we know we aren't going + * to fail the build of the table. + */ + + jtPtr = AllocJumptable(); + + /* + * Fill the keys and labels into the table. + */ + + DEBUG_PRINT("jump table {\n"); + for (i = 0; i < objc; i+=2) { + DEBUG_PRINT(" %s -> %s\n", TclGetString(objv[i]), + TclGetString(objv[i+1])); + hPtr = Tcl_CreateHashEntry(&jtPtr->hashTable, TclGetString(objv[i]), + &isNew); + if (!isNew) { + if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "duplicate entry in jump table for \"%s\"", + TclGetString(objv[i]))); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "DUPJUMPTABLEENTRY", (char *)NULL); + } + DeleteMirrorJumpTable(jtPtr, NULL); + return TCL_ERROR; } - return TCL_ERROR; - } - if (TclListObjGetElements(interp, jumps, &objc, &objv) != TCL_OK) { - return TCL_ERROR; + Tcl_SetHashValue(hPtr, objv[i+1]); + Tcl_IncrRefCount(objv[i+1]); } + DEBUG_PRINT("}\n"); /* - * Allocate the jumptable. + * Put the mirror jumptable in the basic block struct. */ - jtPtr = (JumptableInfo*)Tcl_Alloc(sizeof(JumptableInfo)); - jtHashPtr = &jtPtr->hashTable; - Tcl_InitHashTable(jtHashPtr, TCL_STRING_KEYS); + bbPtr->jtPtr = jtPtr; + return TCL_OK; +} + +/* + *----------------------------------------------------------------------------- + * + * CreateMirrorNumJumpTable -- + * + * Makes a jump table with comparison values and assembly code labels. + * + * Results: + * Returns a standard Tcl status, with an error message in the + * interpreter on error. + * + * Side effects: + * Initializes the jump table pointer in the current basic block to a + * JumptableNumInfo. The keys in the JumptableNumInfo are the comparison + * integers. The values, instead of being jump displacements, are + * Tcl_Obj's with the code labels. + */ + +static int +CreateMirrorNumJumpTable( + AssemblyEnv* assemEnvPtr, /* Assembly environment */ + Tcl_Size objc, /* Number of elements in the 'jumps' list */ + Tcl_Obj** objv) /* Pointers to the elements in the list */ +{ + CompileEnv* envPtr = assemEnvPtr->envPtr; + /* Compilation environment */ + Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; + /* Tcl interpreter */ + BasicBlock* bbPtr = assemEnvPtr->curr_bb; + /* Current basic block */ + JumptableNumInfo* jtnPtr; + Tcl_HashEntry* hPtr; /* Entry for a key in the hashtable */ + int isNew; /* Flag==1 if the key is not yet in the + * table. */ + Tcl_Size i; + Tcl_WideInt key; + + /* + * Allocate the jumptable. Don't write to BB until we know we aren't going + * to fail the build of the table. + */ + + jtnPtr = AllocJumptableNum(); /* * Fill the keys and labels into the table. @@ -2010,19 +2046,26 @@ CreateMirrorJumpTable( for (i = 0; i < objc; i+=2) { DEBUG_PRINT(" %s -> %s\n", TclGetString(objv[i]), TclGetString(objv[i+1])); - hashEntry = Tcl_CreateHashEntry(jtHashPtr, TclGetString(objv[i]), - &isNew); + if (Tcl_GetWideIntFromObj(NULL, objv[i], &key) != TCL_OK) { + if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "jump table must have 64-bit integer keys", + TCL_AUTO_LENGTH)); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADJUMPTABLEENTRY", (char *)NULL); + } + goto error; + } + hPtr = Tcl_CreateHashEntry(&jtnPtr->hashTable, INT2PTR(key), &isNew); if (!isNew) { if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "duplicate entry in jump table for \"%s\"", TclGetString(objv[i]))); Tcl_SetErrorCode(interp, "TCL", "ASSEM", "DUPJUMPTABLEENTRY", (char *)NULL); - DeleteMirrorJumpTable(jtPtr); - return TCL_ERROR; } + goto error; } - Tcl_SetHashValue(hashEntry, objv[i+1]); + Tcl_SetHashValue(hPtr, objv[i+1]); Tcl_IncrRefCount(objv[i+1]); } DEBUG_PRINT("}\n"); @@ -2031,8 +2074,12 @@ CreateMirrorJumpTable( * Put the mirror jumptable in the basic block struct. */ - bbPtr->jtPtr = jtPtr; + bbPtr->jtnPtr = jtnPtr; return TCL_OK; + + error: + DeleteMirrorJumpTable(NULL, jtnPtr); + return TCL_ERROR; } /* @@ -2047,23 +2094,38 @@ CreateMirrorJumpTable( static void DeleteMirrorJumpTable( - JumptableInfo* jtPtr) + JumptableInfo* jtPtr, + JumptableNumInfo* jtnPtr) { - Tcl_HashTable* jtHashPtr = &jtPtr->hashTable; - /* Hash table pointer */ + Tcl_HashTable* hashPtr; /* Hash table pointer */ Tcl_HashSearch search; /* Hash search control */ Tcl_HashEntry* entry; /* Hash table entry containing a jump label */ Tcl_Obj* label; /* Jump label from the hash table */ - for (entry = Tcl_FirstHashEntry(jtHashPtr, &search); - entry != NULL; - entry = Tcl_NextHashEntry(&search)) { - label = (Tcl_Obj*)Tcl_GetHashValue(entry); - Tcl_DecrRefCount(label); - Tcl_SetHashValue(entry, NULL); + if (jtPtr) { + hashPtr = &jtPtr->hashTable; + for (entry = Tcl_FirstHashEntry(hashPtr, &search); + entry != NULL; + entry = Tcl_NextHashEntry(&search)) { + label = (Tcl_Obj*)Tcl_GetHashValue(entry); + Tcl_DecrRefCount(label); + Tcl_SetHashValue(entry, NULL); + } + Tcl_DeleteHashTable(hashPtr); + Tcl_Free(jtPtr); + } + if (jtnPtr) { + hashPtr = &jtnPtr->hashTable; + for (entry = Tcl_FirstHashEntry(hashPtr, &search); + entry != NULL; + entry = Tcl_NextHashEntry(&search)) { + label = (Tcl_Obj*)Tcl_GetHashValue(entry); + Tcl_DecrRefCount(label); + Tcl_SetHashValue(entry, NULL); + } + Tcl_DeleteHashTable(hashPtr); + Tcl_Free(jtnPtr); } - Tcl_DeleteHashTable(jtHashPtr); - Tcl_Free(jtPtr); } /* @@ -2101,7 +2163,8 @@ GetNextOperand( Tcl_DecrRefCount(operandObj); if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "assembly code may not contain substitutions", -1)); + "assembly code may not contain substitutions", + TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NOSUBST", (char *)NULL); } return TCL_ERROR; @@ -2324,7 +2387,7 @@ FindLocalVar( if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "cannot use this instruction to create a variable" - " in a non-proc context", -1)); + " in a non-proc context", TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "ASSEM", "LVT", (char *)NULL); } return TCL_INDEX_NONE; @@ -2352,7 +2415,7 @@ static int CheckNamespaceQualifiers( Tcl_Interp* interp, /* Tcl interpreter for error reporting */ const char* name, /* Variable name to check */ - int nameLen) /* Length of the variable */ + Tcl_Size nameLen) /* Length of the variable */ { const char* p; @@ -2379,23 +2442,17 @@ CheckNamespaceQualifiers( * On success, returns TCL_OK. On failure, returns TCL_ERROR and stores * an error message in the interpreter result. * - * This code is here primarily to verify that instructions like INCR_SCALAR1 - * are possible on a given local variable. The fact that there is no - * INCR_SCALAR4 is puzzling. - * *----------------------------------------------------------------------------- */ static int CheckOneByte( Tcl_Interp* interp, /* Tcl interpreter for error reporting */ - int value) /* Value to check */ + Tcl_Size value) /* Value to check */ { - Tcl_Obj* result; /* Error message */ - if (value < 0 || value > 0xFF) { - result = Tcl_NewStringObj("operand does not fit in one byte", -1); - Tcl_SetObjResult(interp, result); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "operand does not fit in one byte", TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "ASSEM", "1BYTE", (char *)NULL); return TCL_ERROR; } @@ -2415,8 +2472,7 @@ CheckOneByte( * an error message in the interpreter result. * * This code is here primarily to verify that instructions like INCR_SCALAR1 - * are possible on a given local variable. The fact that there is no - * INCR_SCALAR4 is puzzling. + * are possible on a given local variable. * *----------------------------------------------------------------------------- */ @@ -2424,13 +2480,11 @@ CheckOneByte( static int CheckSignedOneByte( Tcl_Interp* interp, /* Tcl interpreter for error reporting */ - int value) /* Value to check */ + Tcl_Size value) /* Value to check */ { - Tcl_Obj* result; /* Error message */ - if (value > 0x7F || value < -0x80) { - result = Tcl_NewStringObj("operand does not fit in one byte", -1); - Tcl_SetObjResult(interp, result); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "operand does not fit in one byte", TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "ASSEM", "1BYTE", (char *)NULL); return TCL_ERROR; } @@ -2457,13 +2511,11 @@ CheckSignedOneByte( static int CheckNonNegative( Tcl_Interp* interp, /* Tcl interpreter for error reporting */ - int value) /* Value to check */ + Tcl_Size value) /* Value to check */ { - Tcl_Obj* result; /* Error message */ - - if (value < 0) { - result = Tcl_NewStringObj("operand must be nonnegative", -1); - Tcl_SetObjResult(interp, result); + if (value < 0 || value > INT_MAX) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "operand must be nonnegative", TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NONNEGATIVE", (char *)NULL); return TCL_ERROR; } @@ -2490,13 +2542,11 @@ CheckNonNegative( static int CheckStrictlyPositive( Tcl_Interp* interp, /* Tcl interpreter for error reporting */ - int value) /* Value to check */ + Tcl_Size value) /* Value to check */ { - Tcl_Obj* result; /* Error message */ - - if (value <= 0) { - result = Tcl_NewStringObj("operand must be positive", -1); - Tcl_SetObjResult(interp, result); + if (value <= 0 || value > INT_MAX) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "operand must be positive", TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "ASSEM", "POSITIVE", (char *)NULL); return TCL_ERROR; } @@ -2593,7 +2643,7 @@ StartBasicBlock( * Coalesce zero-length blocks. */ - if (currBB->startOffset == envPtr->codeNext - envPtr->codeStart) { + if (currBB->startOffset == CurrentOffset(envPtr)) { currBB->startLine = assemEnvPtr->cmdLine; return currBB; } @@ -2649,8 +2699,7 @@ AllocBB( CompileEnv* envPtr = assemEnvPtr->envPtr; BasicBlock *bb = (BasicBlock*)Tcl_Alloc(sizeof(BasicBlock)); - bb->originalStartOffset = - bb->startOffset = envPtr->codeNext - envPtr->codeStart; + bb->startOffset = CurrentOffset(envPtr); bb->startLine = assemEnvPtr->cmdLine + 1; bb->jumpOffset = -1; bb->jumpLine = -1; @@ -2668,6 +2717,7 @@ AllocBB( bb->foreignExceptionCount = 0; bb->foreignExceptions = NULL; bb->jtPtr = NULL; + bb->jtnPtr = NULL; bb->flags = 0; return bb; @@ -2698,27 +2748,15 @@ static int FinishAssembly( AssemblyEnv* assemEnvPtr) /* Assembly environment */ { - int mustMove; /* Amount by which the code needs to be grown - * because of expanding jumps */ - /* - * Resolve the targets of all jumps and determine whether code needs to be - * moved around. + * Resolve the targets of all jumps. */ - if (CalculateJumpRelocations(assemEnvPtr, &mustMove)) { + if (ValidateJumpTargets(assemEnvPtr)) { return TCL_ERROR; } /* - * Move the code if necessary. - */ - - if (mustMove) { - MoveCodeForJumps(assemEnvPtr, mustMove); - } - - /* * Resolve jump target labels to bytecode offsets. */ @@ -2760,114 +2798,62 @@ FinishAssembly( /* *----------------------------------------------------------------------------- * - * CalculateJumpRelocations -- + * ValidateJumpTargets -- * - * Calculate any movement that has to be done in the assembly code to - * expand JUMP1 instructions to JUMP4 (because they jump more than a - * 1-byte range). + * Checks for undefined labels and reports them. * * Results: * Returns a standard Tcl result, with an appropriate error message if * anything fails. * * Side effects: - * Sets the 'startOffset' pointer in every basic block to the new origin - * of the block, and turns off JUMP1 flags on instructions that must be - * expanded (and adjusts them to the corresponding JUMP4's). Does *not* - * store the jump offsets at this point. - * - * Sets *mustMove to 1 if and only if at least one instruction changed - * size so the code must be moved. - * - * As a side effect, also checks for undefined labels and reports them. + * None. * *----------------------------------------------------------------------------- */ static int -CalculateJumpRelocations( - AssemblyEnv* assemEnvPtr, /* Assembly environment */ - int* mustMove) /* OUTPUT: Number of bytes that have been - * added to the code */ +ValidateJumpTargets( + AssemblyEnv* assemEnvPtr) /* Assembly environment */ { - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ BasicBlock* bbPtr; /* Pointer to a basic block being checked */ Tcl_HashEntry* entry; /* Exit label's entry in the symbol table */ - BasicBlock* jumpTarget; /* Basic block where the jump goes */ - int motion; /* Amount by which the code has expanded */ - int offset; /* Offset in the bytecode from a jump - * instruction to its target */ - unsigned opcode; /* Opcode in the bytecode being adjusted */ /* - * Iterate through basic blocks as long as a change results in code - * expansion. + * Iterate through basic blocks. */ - *mustMove = 0; - do { - motion = 0; - for (bbPtr = assemEnvPtr->head_bb; - bbPtr != NULL; - bbPtr = bbPtr->successor1) { - /* - * Advance the basic block start offset by however many bytes we - * have inserted in the code up to this point - */ - - bbPtr->startOffset += motion; - - /* - * If the basic block references a label (and hence performs a - * jump), find the location of the label. Report an error if the - * label is missing. - */ - - if (bbPtr->jumpTarget != NULL) { - entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - TclGetString(bbPtr->jumpTarget)); - if (entry == NULL) { - ReportUndefinedLabel(assemEnvPtr, bbPtr, - bbPtr->jumpTarget); - return TCL_ERROR; - } + for (bbPtr = assemEnvPtr->head_bb; + bbPtr != NULL; + bbPtr = bbPtr->successor1) { + /* + * If the basic block references a label (and hence performs a + * jump), find the location of the label. Report an error if the + * label is missing. + */ - /* - * If the instruction is a JUMP1, turn it into a JUMP4 if its - * target is out of range. - */ - - jumpTarget = (BasicBlock*)Tcl_GetHashValue(entry); - if (bbPtr->flags & BB_JUMP1) { - offset = jumpTarget->startOffset - - (bbPtr->jumpOffset + motion); - if (offset < -0x80 || offset > 0x7F) { - opcode = TclGetUInt1AtPtr(envPtr->codeStart - + bbPtr->jumpOffset); - ++opcode; - TclStoreInt1AtPtr(opcode, - envPtr->codeStart + bbPtr->jumpOffset); - motion += 3; - bbPtr->flags &= ~BB_JUMP1; - } - } + if (bbPtr->jumpTarget != NULL) { + entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash, + TclGetString(bbPtr->jumpTarget)); + if (entry == NULL) { + ReportUndefinedLabel(assemEnvPtr, bbPtr, + bbPtr->jumpTarget); + return TCL_ERROR; } + } - /* - * If the basic block references a jump table, that doesn't affect - * the code locations, but resolve the labels now, and store basic - * block pointers in the jumptable hash. - */ + /* + * If the basic block references a jump table, that doesn't affect + * the code locations, but resolve the labels now, and store basic + * block pointers in the jumptable hash. + */ - if (bbPtr->flags & BB_JUMPTABLE) { - if (CheckJumpTableLabels(assemEnvPtr, bbPtr) != TCL_OK) { - return TCL_ERROR; - } + if (bbPtr->flags & BB_JUMPTABLE) { + if (CheckJumpTableLabels(assemEnvPtr, bbPtr) != TCL_OK) { + return TCL_ERROR; } } - *mustMove += motion; - } while (motion != 0); + } return TCL_OK; } @@ -2890,8 +2876,7 @@ CheckJumpTableLabels( AssemblyEnv* assemEnvPtr, /* Assembly environment */ BasicBlock* bbPtr) /* Basic block that ends in a jump table */ { - Tcl_HashTable* symHash = &bbPtr->jtPtr->hashTable; - /* Hash table with the symbols */ + Tcl_HashTable* symHash; /* Hash table with the symbols */ Tcl_HashSearch search; /* Hash table iterator */ Tcl_HashEntry* symEntryPtr; /* Hash entry for the symbols */ Tcl_Obj* symbolObj; /* Jump target */ @@ -2902,18 +2887,37 @@ CheckJumpTableLabels( */ DEBUG_PRINT("check jump table labels %p {\n", bbPtr); - for (symEntryPtr = Tcl_FirstHashEntry(symHash, &search); - symEntryPtr != NULL; - symEntryPtr = Tcl_NextHashEntry(&search)) { - symbolObj = (Tcl_Obj*)Tcl_GetHashValue(symEntryPtr); - valEntryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - TclGetString(symbolObj)); - DEBUG_PRINT(" %s -> %s (%d)\n", - (char *)Tcl_GetHashKey(symHash, symEntryPtr), - TclGetString(symbolObj), (valEntryPtr != NULL)); - if (valEntryPtr == NULL) { - ReportUndefinedLabel(assemEnvPtr, bbPtr, symbolObj); - return TCL_ERROR; + if (bbPtr->jtPtr) { + symHash = &bbPtr->jtPtr->hashTable; + for (symEntryPtr = Tcl_FirstHashEntry(symHash, &search); + symEntryPtr != NULL; + symEntryPtr = Tcl_NextHashEntry(&search)) { + symbolObj = (Tcl_Obj*)Tcl_GetHashValue(symEntryPtr); + valEntryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash, + TclGetString(symbolObj)); + DEBUG_PRINT(" %s -> %s (%d)\n", + (char *)Tcl_GetHashKey(symHash, symEntryPtr), + TclGetString(symbolObj), (valEntryPtr != NULL)); + if (valEntryPtr == NULL) { + ReportUndefinedLabel(assemEnvPtr, bbPtr, symbolObj); + return TCL_ERROR; + } + } + } else { + symHash = &bbPtr->jtnPtr->hashTable; + for (symEntryPtr = Tcl_FirstHashEntry(symHash, &search); + symEntryPtr != NULL; + symEntryPtr = Tcl_NextHashEntry(&search)) { + symbolObj = (Tcl_Obj*)Tcl_GetHashValue(symEntryPtr); + valEntryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash, + TclGetString(symbolObj)); + DEBUG_PRINT(" %" TCL_SIZE_MODIFIER "d -> %s (%d)\n", + (Tcl_Size)Tcl_GetHashKey(symHash, symEntryPtr), + TclGetString(symbolObj), (valEntryPtr != NULL)); + if (valEntryPtr == NULL) { + ReportUndefinedLabel(assemEnvPtr, bbPtr, symbolObj); + return TCL_ERROR; + } } } DEBUG_PRINT("}\n"); @@ -2958,55 +2962,6 @@ ReportUndefinedLabel( /* *----------------------------------------------------------------------------- * - * MoveCodeForJumps -- - * - * Move bytecodes in memory to accommodate JUMP1 instructions that have - * expanded to become JUMP4's. - * - *----------------------------------------------------------------------------- - */ - -static void -MoveCodeForJumps( - AssemblyEnv* assemEnvPtr, /* Assembler environment */ - int mustMove) /* Number of bytes of added code */ -{ - CompileEnv* envPtr = assemEnvPtr->envPtr; - /* Compilation environment */ - BasicBlock* bbPtr; /* Pointer to a basic block being checked */ - int topOffset; /* Bytecode offset of the following basic - * block before code motion */ - - /* - * Make sure that there is enough space in the bytecode array to - * accommodate the expanded code. - */ - - while (envPtr->codeEnd < envPtr->codeNext + mustMove) { - TclExpandCodeArray(envPtr); - } - - /* - * Iterate through the bytecodes in reverse order, and move them upward to - * their new homes. - */ - - topOffset = envPtr->codeNext - envPtr->codeStart; - for (bbPtr = assemEnvPtr->curr_bb; bbPtr != NULL; bbPtr = bbPtr->prevPtr) { - DEBUG_PRINT("move code from %d to %d\n", - bbPtr->originalStartOffset, bbPtr->startOffset); - memmove(envPtr->codeStart + bbPtr->startOffset, - envPtr->codeStart + bbPtr->originalStartOffset, - topOffset - bbPtr->originalStartOffset); - topOffset = bbPtr->originalStartOffset; - bbPtr->jumpOffset += (bbPtr->startOffset - bbPtr->originalStartOffset); - } - envPtr->codeNext += mustMove; -} - -/* - *----------------------------------------------------------------------------- - * * FillInJumpOffsets -- * * Fill in the final offsets of all jump instructions once bytecode @@ -3037,13 +2992,8 @@ FillInJumpOffsets( jumpTarget = (BasicBlock*)Tcl_GetHashValue(entry); fromOffset = bbPtr->jumpOffset; targetOffset = jumpTarget->startOffset; - if (bbPtr->flags & BB_JUMP1) { - TclStoreInt1AtPtr(targetOffset - fromOffset, - envPtr->codeStart + fromOffset + 1); - } else { - TclStoreInt4AtPtr(targetOffset - fromOffset, - envPtr->codeStart + fromOffset + 1); - } + TclStoreInt4AtPtr(targetOffset - fromOffset, + envPtr->codeStart + fromOffset + 1); } if (bbPtr->flags & BB_JUMPTABLE) { ResolveJumpTableTargets(assemEnvPtr, bbPtr); @@ -3072,15 +3022,11 @@ ResolveJumpTableTargets( { CompileEnv* envPtr = assemEnvPtr->envPtr; /* Compilation environment */ - Tcl_HashTable* symHash = &bbPtr->jtPtr->hashTable; - /* Hash table with the symbols */ + Tcl_HashTable* symHash; /* Hash table with the symbols */ Tcl_HashSearch search; /* Hash table iterator */ Tcl_HashEntry* symEntryPtr; /* Hash entry for the symbols */ Tcl_Obj* symbolObj; /* Jump target */ Tcl_HashEntry* valEntryPtr; /* Hash entry for the resolutions */ - int auxDataIndex; /* Index of the auxdata */ - JumptableInfo* realJumpTablePtr; - /* Jump table in the actual code */ Tcl_HashTable* realJumpHashPtr; /* Jump table hash in the actual code */ Tcl_HashEntry* realJumpEntryPtr; @@ -3088,40 +3034,91 @@ ResolveJumpTableTargets( * the actual code */ BasicBlock* jumpTargetBBPtr; /* Basic block that the jump proceeds to */ - int junk; - auxDataIndex = TclGetInt4AtPtr(envPtr->codeStart + bbPtr->jumpOffset + 1); - DEBUG_PRINT("bbPtr = %p jumpOffset = %d auxDataIndex = %d\n", - bbPtr, bbPtr->jumpOffset, auxDataIndex); - realJumpTablePtr = (JumptableInfo*)TclFetchAuxData(envPtr, auxDataIndex); - realJumpHashPtr = &realJumpTablePtr->hashTable; + if (bbPtr->jtPtr) { + int auxDataIndex; /* Index of the auxdata */ + JumptableInfo* realJumpTablePtr; + /* Jump table in the actual code */ - /* - * Look up every jump target in the jump hash. - */ + symHash = &bbPtr->jtPtr->hashTable; + auxDataIndex = TclGetInt4AtPtr( + envPtr->codeStart + bbPtr->jumpOffset + 1); + DEBUG_PRINT("bbPtr = %p jumpOffset = %d auxDataIndex = %d\n", + bbPtr, bbPtr->jumpOffset, auxDataIndex); + realJumpTablePtr = (JumptableInfo*) + TclFetchAuxData(envPtr, auxDataIndex); + realJumpHashPtr = &realJumpTablePtr->hashTable; + + /* + * Look up every jump target in the jump hash. + */ - DEBUG_PRINT("resolve jump table {\n"); - for (symEntryPtr = Tcl_FirstHashEntry(symHash, &search); - symEntryPtr != NULL; - symEntryPtr = Tcl_NextHashEntry(&search)) { - symbolObj = (Tcl_Obj*)Tcl_GetHashValue(symEntryPtr); - DEBUG_PRINT(" symbol %s\n", TclGetString(symbolObj)); - - valEntryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - TclGetString(symbolObj)); - jumpTargetBBPtr = (BasicBlock*)Tcl_GetHashValue(valEntryPtr); - - realJumpEntryPtr = Tcl_CreateHashEntry(realJumpHashPtr, - Tcl_GetHashKey(symHash, symEntryPtr), &junk); - DEBUG_PRINT(" %s -> %s -> bb %p (pc %d) hash entry %p\n", - (char *)Tcl_GetHashKey(symHash, symEntryPtr), - TclGetString(symbolObj), jumpTargetBBPtr, - jumpTargetBBPtr->startOffset, realJumpEntryPtr); - - Tcl_SetHashValue(realJumpEntryPtr, - INT2PTR(jumpTargetBBPtr->startOffset - bbPtr->jumpOffset)); + DEBUG_PRINT("resolve jump table {\n"); + for (symEntryPtr = Tcl_FirstHashEntry(symHash, &search); + symEntryPtr != NULL; + symEntryPtr = Tcl_NextHashEntry(&search)) { + symbolObj = (Tcl_Obj*)Tcl_GetHashValue(symEntryPtr); + DEBUG_PRINT(" symbol %s\n", TclGetString(symbolObj)); + + valEntryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash, + TclGetString(symbolObj)); + jumpTargetBBPtr = (BasicBlock*)Tcl_GetHashValue(valEntryPtr); + + realJumpEntryPtr = Tcl_CreateHashEntry(realJumpHashPtr, + Tcl_GetHashKey(symHash, symEntryPtr), NULL); + DEBUG_PRINT(" %s -> %s -> bb %p (pc %d) hash entry %p\n", + (char *)Tcl_GetHashKey(symHash, symEntryPtr), + TclGetString(symbolObj), jumpTargetBBPtr, + jumpTargetBBPtr->startOffset, realJumpEntryPtr); + + Tcl_SetHashValue(realJumpEntryPtr, + INT2PTR(jumpTargetBBPtr->startOffset - bbPtr->jumpOffset)); + } + DEBUG_PRINT("}\n"); + } else { + int auxDataIndex; /* Index of the auxdata */ + JumptableNumInfo* realNumJumpTablePtr; + /* Jump table in the actual code */ + + assert(bbPtr->jtnPtr); + symHash = &bbPtr->jtnPtr->hashTable; + auxDataIndex = TclGetInt4AtPtr( + envPtr->codeStart + bbPtr->jumpOffset + 1); + DEBUG_PRINT("bbPtr = %p jumpOffset = %d auxDataIndex = %d\n", + bbPtr, bbPtr->jumpOffset, auxDataIndex); + realNumJumpTablePtr = (JumptableNumInfo*) + TclFetchAuxData(envPtr, auxDataIndex); + realJumpHashPtr = &realNumJumpTablePtr->hashTable; + + /* + * Look up every jump target in the jump hash. + */ + + DEBUG_PRINT("resolve jump table {\n"); + for (symEntryPtr = Tcl_FirstHashEntry(symHash, &search); + symEntryPtr != NULL; + symEntryPtr = Tcl_NextHashEntry(&search)) { + symbolObj = (Tcl_Obj*)Tcl_GetHashValue(symEntryPtr); + DEBUG_PRINT(" symbol %s\n", TclGetString(symbolObj)); + + valEntryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash, + TclGetString(symbolObj)); + jumpTargetBBPtr = (BasicBlock*)Tcl_GetHashValue(valEntryPtr); + + realJumpEntryPtr = Tcl_CreateHashEntry(realJumpHashPtr, + Tcl_GetHashKey(symHash, symEntryPtr), NULL); + DEBUG_PRINT( + " %" TCL_SIZE_MODIFIER "d -> %s -> bb %p (pc %d)" + " hash entry %p\n", + (Tcl_Size) Tcl_GetHashKey(symHash, symEntryPtr), + TclGetString(symbolObj), jumpTargetBBPtr, + jumpTargetBBPtr->startOffset, realJumpEntryPtr); + + Tcl_SetHashValue(realJumpEntryPtr, + INT2PTR(jumpTargetBBPtr->startOffset - bbPtr->jumpOffset)); + } + DEBUG_PRINT("}\n"); } - DEBUG_PRINT("}\n"); } /* @@ -3196,9 +3193,9 @@ CheckNonThrowingBlock( Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; /* Tcl interpreter */ BasicBlock* nextPtr; /* Pointer to the succeeding basic block */ - int offset; /* Bytecode offset of the current + Tcl_Size offset; /* Bytecode offset of the current * instruction */ - int bound; /* Bytecode offset following the last + Tcl_Size bound; /* Bytecode offset following the last * instruction of the block. */ unsigned char opcode; /* Current bytecode instruction */ @@ -3208,7 +3205,7 @@ CheckNonThrowingBlock( nextPtr = blockPtr->successor1; if (nextPtr == NULL) { - bound = envPtr->codeNext - envPtr->codeStart; + bound = CurrentOffset(envPtr); } else { bound = nextPtr->startOffset; } @@ -3408,7 +3405,8 @@ StackCheckBasicBlock( } if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "inconsistent stack depths on two execution paths", -1)); + "inconsistent stack depths on two execution paths", + TCL_AUTO_LENGTH)); /* * TODO - add execution trace of both paths @@ -3437,7 +3435,8 @@ StackCheckBasicBlock( if (initialStackDepth + blockPtr->minStackDepth < 0) { if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("stack underflow", -1)); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "stack underflow", TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACK", (char *)NULL); AddBasicBlockRangeToErrorInfo(assemEnvPtr, blockPtr); Tcl_SetErrorLine(interp, blockPtr->startLine); @@ -3456,7 +3455,8 @@ StackCheckBasicBlock( + blockPtr->enclosingCatch->finalStackDepth)) { if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "code pops stack below level of enclosing catch", -1)); + "code pops stack below level of enclosing catch", + TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACKINCATCH", (char *)NULL); AddBasicBlockRangeToErrorInfo(assemEnvPtr, blockPtr); Tcl_SetErrorLine(interp, blockPtr->startLine); @@ -3498,8 +3498,9 @@ StackCheckBasicBlock( */ if (blockPtr->flags & BB_JUMPTABLE) { - for (jtEntry = Tcl_FirstHashEntry(&blockPtr->jtPtr->hashTable, - &jtSearch); + Tcl_HashTable *tablePtr = (blockPtr->jtPtr ? + &blockPtr->jtPtr->hashTable : &blockPtr->jtnPtr->hashTable); + for (jtEntry = Tcl_FirstHashEntry(tablePtr, &jtSearch); result == TCL_OK && jtEntry != NULL; jtEntry = Tcl_NextHashEntry(&jtSearch)) { targetLabel = (Tcl_Obj*)Tcl_GetHashValue(jtEntry); @@ -3572,7 +3573,7 @@ StackCheckExit( * Assumes that 'push' is at slot 0 in TalInstructionTable. */ - BBEmitInst1or4(assemEnvPtr, 0, litIndex, 0); + BBEmitInstInt4(assemEnvPtr, 0, litIndex, 0); ++depth; } @@ -3728,7 +3729,7 @@ ProcessCatchesInBasicBlock( if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "execution reaches an instruction in inconsistent " - "exception contexts", -1)); + "exception contexts", TCL_AUTO_LENGTH)); Tcl_SetErrorLine(interp, bbPtr->startLine); Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADCATCH", (char *)NULL); } @@ -3787,7 +3788,8 @@ ProcessCatchesInBasicBlock( if (enclosing == NULL) { if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "endCatch without a corresponding beginCatch", -1)); + "endCatch without a corresponding beginCatch", + TCL_AUTO_LENGTH)); Tcl_SetErrorLine(interp, bbPtr->startLine); Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADENDCATCH", (char *)NULL); } @@ -3820,7 +3822,9 @@ ProcessCatchesInBasicBlock( */ if (bbPtr->flags & BB_JUMPTABLE) { - for (jtEntry = Tcl_FirstHashEntry(&bbPtr->jtPtr->hashTable,&jtSearch); + Tcl_HashTable *tablePtr = (bbPtr->jtPtr ? + &bbPtr->jtPtr->hashTable : &bbPtr->jtnPtr->hashTable); + for (jtEntry = Tcl_FirstHashEntry(tablePtr, &jtSearch); result == TCL_OK && jtEntry != NULL; jtEntry = Tcl_NextHashEntry(&jtSearch)) { targetLabel = (Tcl_Obj*)Tcl_GetHashValue(jtEntry); @@ -3862,7 +3866,8 @@ CheckForUnclosedCatches( if (assemEnvPtr->curr_bb->catchState >= BBCS_INCATCH) { if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "catch still active on exit from assembly code", -1)); + "catch still active on exit from assembly code", + TCL_AUTO_LENGTH)); Tcl_SetErrorLine(interp, assemEnvPtr->curr_bb->enclosingCatch->startLine); Tcl_SetErrorCode(interp, "TCL", "ASSEM", "UNCLOSEDCATCH", (char *)NULL); @@ -3906,7 +3911,7 @@ BuildExceptionRanges( int catchDepth = 0; /* Current catch depth */ int maxCatchDepth = 0; /* Maximum catch depth in the program */ BasicBlock** catches; /* Stack of catches in progress */ - int* catchIndices; /* Indices of the exception ranges of catches + Tcl_Size* catchIndices; /* Indices of the exception ranges of catches * in progress */ int i; @@ -3926,7 +3931,7 @@ BuildExceptionRanges( */ catches = (BasicBlock**)Tcl_Alloc(maxCatchDepth * sizeof(BasicBlock*)); - catchIndices = (int *)Tcl_Alloc(maxCatchDepth * sizeof(int)); + catchIndices = (Tcl_Size *)Tcl_Alloc(maxCatchDepth * sizeof(Tcl_Size)); for (i = 0; i < maxCatchDepth; ++i) { catches[i] = NULL; catchIndices[i] = -1; @@ -3949,7 +3954,7 @@ BuildExceptionRanges( catchDepth = bbPtr->catchDepth; if (prevPtr != NULL && (prevPtr->flags & BB_BEGINCATCH)) { - TclStoreInt4AtPtr(catchIndices[catchDepth-1], + TclStoreInt4AtPtr(catchIndices[catchDepth - 1], envPtr->codeStart + bbPtr->startOffset - 4); } @@ -3985,12 +3990,12 @@ BuildExceptionRanges( static void UnstackExpiredCatches( - CompileEnv* envPtr, /* Compilation environment */ - BasicBlock* bbPtr, /* Basic block being processed */ + CompileEnv *envPtr, /* Compilation environment */ + BasicBlock *bbPtr, /* Basic block being processed */ int catchDepth, /* Depth of nesting of catches prior to entry * to this block */ - BasicBlock** catches, /* Array of catch contexts */ - int* catchIndices) /* Indices of the exception ranges + BasicBlock **catches, /* Array of catch contexts */ + Tcl_Size *catchIndices) /* Indices of the exception ranges * corresponding to the catch contexts */ { ExceptionRange* range; /* Exception range for a specific catch */ @@ -4096,7 +4101,7 @@ StackFreshCatches( int catchDepth, /* Depth of nesting of catches prior to entry * to this block */ BasicBlock** catches, /* Array of catch contexts */ - int* catchIndices) /* Indices of the exception ranges + Tcl_Size* catchIndices) /* Indices of the exception ranges * corresponding to the catch contexts */ { CompileEnv* envPtr = assemEnvPtr->envPtr; @@ -4159,13 +4164,13 @@ RestoreEmbeddedExceptionRanges( CompileEnv* envPtr = assemEnvPtr->envPtr; /* Compilation environment */ BasicBlock* bbPtr; /* Current basic block */ - int rangeBase; /* Base of the foreign exception ranges when + Tcl_Size rangeBase; /* Base of the foreign exception ranges when * they are reinstalled */ size_t rangeIndex; /* Index of the current foreign exception * range as reinstalled */ ExceptionRange* range; /* Current foreign exception range */ unsigned char opcode; /* Current instruction's opcode */ - int catchIndex; /* Index of the exception range to which the + Tcl_Size catchIndex; /* Index of the exception range to which the * current instruction refers */ int i; @@ -4195,13 +4200,13 @@ RestoreEmbeddedExceptionRanges( /* * Walk through the bytecode of the basic block, and relocate - * INST_BEGIN_CATCH4 instructions to the new locations + * INST_BEGIN_CATCH instructions to the new locations */ i = bbPtr->startOffset; while (i < bbPtr->successor1->startOffset) { opcode = envPtr->codeStart[i]; - if (opcode == INST_BEGIN_CATCH4) { + if (opcode == INST_BEGIN_CATCH) { catchIndex = TclGetUInt4AtPtr(envPtr->codeStart + i + 1); if (catchIndex >= bbPtr->foreignExceptionBase && catchIndex < (bbPtr->foreignExceptionBase + @@ -4263,20 +4268,16 @@ AddBasicBlockRangeToErrorInfo( /* Compilation environment */ Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; /* Tcl interpreter */ - Tcl_Obj* lineNo; /* Line number in the source */ - Tcl_AddErrorInfo(interp, "\n in assembly code between lines "); - TclNewIntObj(lineNo, bbPtr->startLine); - Tcl_IncrRefCount(lineNo); - Tcl_AppendObjToErrorInfo(interp, lineNo); - Tcl_AddErrorInfo(interp, " and "); if (bbPtr->successor1 != NULL) { - TclSetIntObj(lineNo, bbPtr->successor1->startLine); - Tcl_AppendObjToErrorInfo(interp, lineNo); - } else { - Tcl_AddErrorInfo(interp, "end of assembly code"); + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n in assembly code between lines %d and %d", + bbPtr->startLine, bbPtr->successor1->startLine)); + return; } - Tcl_DecrRefCount(lineNo); + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n in assembly code between line %d and end of assembly code", + bbPtr->startLine)); } /* diff --git a/generic/tclAsync.c b/generic/tclAsync.c index f0f0c9c..7a5b862 100644 --- a/generic/tclAsync.c +++ b/generic/tclAsync.c @@ -30,7 +30,7 @@ typedef struct AsyncHandler { * for the process. */ Tcl_AsyncProc *proc; /* Procedure to call when handler is * invoked. */ - void *clientData; /* Value to pass to handler when it is + void *clientData; /* Value to pass to handler when it is * invoked. */ struct ThreadSpecificData *originTsd; /* Used in Tcl_AsyncMark to modify thread- @@ -38,7 +38,7 @@ typedef struct AsyncHandler { * associated to. */ Tcl_ThreadId originThrdId; /* Origin thread where this token was created * and where it will be yielded. */ - void *notifierData; /* Platform notifier data or NULL. */ + void *notifierData; /* Platform notifier data or NULL. */ } AsyncHandler; typedef struct ThreadSpecificData { @@ -142,7 +142,7 @@ Tcl_AsyncHandler Tcl_AsyncCreate( Tcl_AsyncProc *proc, /* Procedure to call when handler is * invoked. */ - void *clientData) /* Argument to pass to handler. */ + void *clientData) /* Argument to pass to handler. */ { AsyncHandler *asyncPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -190,7 +190,7 @@ Tcl_AsyncCreate( void Tcl_AsyncMark( - Tcl_AsyncHandler async) /* Token for handler. */ + Tcl_AsyncHandler async) /* Token for handler. */ { AsyncHandler *token = (AsyncHandler *) async; @@ -201,7 +201,6 @@ Tcl_AsyncMark( Tcl_ThreadAlert(token->originThrdId); } Tcl_MutexUnlock(&asyncMutex); - } /* @@ -224,8 +223,8 @@ Tcl_AsyncMark( int Tcl_AsyncMarkFromSignal( - Tcl_AsyncHandler async, /* Token for handler. */ - int sigNumber) /* Signal number. */ + Tcl_AsyncHandler async, /* Token for handler. */ + int sigNumber) /* Signal number. */ { #if TCL_THREADS AsyncHandler *token = (AsyncHandler *) async; @@ -378,7 +377,7 @@ Tcl_AsyncInvoke( void Tcl_AsyncDelete( - Tcl_AsyncHandler async) /* Token for handler to delete. */ + Tcl_AsyncHandler async) /* Token for handler to delete. */ { AsyncHandler *asyncPtr = (AsyncHandler *) async; diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 94d464f..1ee1a8d 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -207,8 +207,8 @@ static Tcl_ObjCmdProc ExprSrandFunc; static Tcl_ObjCmdProc ExprUnaryFunc; static Tcl_ObjCmdProc ExprWideFunc; static Tcl_ObjCmdProc FloatClassifyObjCmd; -static void MathFuncWrongNumArgs(Tcl_Interp *interp, int expected, - int actual, Tcl_Obj *const *objv); +static void MathFuncWrongNumArgs(Tcl_Interp *interp, Tcl_Size expected, + Tcl_Size actual, Tcl_Obj *const *objv); static Tcl_NRPostProc NRCoroutineCallerCallback; static Tcl_NRPostProc NRCoroutineExitCallback; static Tcl_NRPostProc NRCommand; @@ -237,7 +237,6 @@ static Tcl_NRPostProc TEOV_RunLeaveTraces; static Tcl_NRPostProc EvalObjvCore; static Tcl_NRPostProc Dispatch; -static Tcl_NRPostProc NRPostInvoke; static Tcl_ObjCmdProc CoroTypeObjCmd; static Tcl_ObjCmdProc TclNRCoroInjectObjCmd; static Tcl_ObjCmdProc TclNRCoroProbeObjCmd; @@ -250,12 +249,10 @@ MODULE_SCOPE const TclStubs tclStubs; * Magical counts for the number of arguments accepted by a coroutine command * after particular kinds of [yield]. */ - -#define CORO_ACTIVATE_YIELD NULL -#define CORO_ACTIVATE_YIELDM INT2PTR(1) - -#define COROUTINE_ARGUMENTS_SINGLE_OPTIONAL (-1) -#define COROUTINE_ARGUMENTS_ARBITRARY (-2) +enum CoroutineArgumentTypes { + COROUTINE_ARGUMENTS_SINGLE_OPTIONAL = -1, + COROUTINE_ARGUMENTS_ARBITRARY = -2 +}; /* * The following structure define the commands in the Tcl core. @@ -299,7 +296,7 @@ typedef struct { */ static int -procObjCmd( +ProcObjCmd( void *clientData, Tcl_Interp *interp, int objc, @@ -310,7 +307,7 @@ procObjCmd( static const CmdInfo builtInCmds[] = { /* - * Commands in the generic core. + * Commands in the generic core. All are safe. */ {"append", Tcl_AppendObjCmd, TclCompileAppendCmd, NULL, CMD_IS_SAFE}, @@ -334,26 +331,26 @@ static const CmdInfo builtInCmds[] = { {"if", Tcl_IfObjCmd, TclCompileIfCmd, TclNRIfObjCmd, CMD_IS_SAFE}, {"incr", Tcl_IncrObjCmd, TclCompileIncrCmd, NULL, CMD_IS_SAFE}, {"join", Tcl_JoinObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"lappend", Tcl_LappendObjCmd, TclCompileLappendCmd, NULL, CMD_IS_SAFE}, + {"lappend", Tcl_LappendObjCmd, TclCompileLappendCmd, NULL, CMD_IS_SAFE|CMD_COMPILES_EXPANDED}, {"lassign", Tcl_LassignObjCmd, TclCompileLassignCmd, NULL, CMD_IS_SAFE}, - {"ledit", Tcl_LeditObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"ledit", Tcl_LeditObjCmd, TclCompileLeditCmd, NULL, CMD_IS_SAFE}, {"lindex", Tcl_LindexObjCmd, TclCompileLindexCmd, NULL, CMD_IS_SAFE}, {"linsert", Tcl_LinsertObjCmd, TclCompileLinsertCmd, NULL, CMD_IS_SAFE}, {"list", Tcl_ListObjCmd, TclCompileListCmd, NULL, CMD_IS_SAFE|CMD_COMPILES_EXPANDED}, {"llength", Tcl_LlengthObjCmd, TclCompileLlengthCmd, NULL, CMD_IS_SAFE}, {"lmap", Tcl_LmapObjCmd, TclCompileLmapCmd, TclNRLmapCmd, CMD_IS_SAFE}, - {"lpop", Tcl_LpopObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"lpop", Tcl_LpopObjCmd, TclCompileLpopCmd, NULL, CMD_IS_SAFE}, {"lrange", Tcl_LrangeObjCmd, TclCompileLrangeCmd, NULL, CMD_IS_SAFE}, {"lremove", Tcl_LremoveObjCmd, NULL, NULL, CMD_IS_SAFE}, {"lrepeat", Tcl_LrepeatObjCmd, NULL, NULL, CMD_IS_SAFE}, {"lreplace", Tcl_LreplaceObjCmd, TclCompileLreplaceCmd, NULL, CMD_IS_SAFE}, {"lreverse", Tcl_LreverseObjCmd, NULL, NULL, CMD_IS_SAFE}, {"lsearch", Tcl_LsearchObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"lseq", Tcl_LseqObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"lseq", Tcl_LseqObjCmd, TclCompileLseqCmd, NULL, CMD_IS_SAFE}, {"lset", Tcl_LsetObjCmd, TclCompileLsetCmd, NULL, CMD_IS_SAFE}, {"lsort", Tcl_LsortObjCmd, NULL, NULL, CMD_IS_SAFE}, {"package", Tcl_PackageObjCmd, NULL, TclNRPackageObjCmd, CMD_IS_SAFE}, - {"proc", procObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"proc", ProcObjCmd, NULL, NULL, CMD_IS_SAFE}, {"regexp", Tcl_RegexpObjCmd, TclCompileRegexpCmd, NULL, CMD_IS_SAFE}, {"regsub", Tcl_RegsubObjCmd, TclCompileRegsubCmd, NULL, CMD_IS_SAFE}, {"rename", Tcl_RenameObjCmd, NULL, NULL, CMD_IS_SAFE}, @@ -363,17 +360,17 @@ static const CmdInfo builtInCmds[] = { {"split", Tcl_SplitObjCmd, NULL, NULL, CMD_IS_SAFE}, {"subst", Tcl_SubstObjCmd, TclCompileSubstCmd, TclNRSubstObjCmd, CMD_IS_SAFE}, {"switch", Tcl_SwitchObjCmd, TclCompileSwitchCmd, TclNRSwitchObjCmd, CMD_IS_SAFE}, - {"tailcall", NULL, TclCompileTailcallCmd, TclNRTailcallObjCmd, CMD_IS_SAFE}, + {"tailcall", NULL, TclCompileTailcallCmd, TclNRTailcallObjCmd, CMD_IS_SAFE|CMD_COMPILES_EXPANDED}, {"throw", Tcl_ThrowObjCmd, TclCompileThrowCmd, NULL, CMD_IS_SAFE}, {"trace", Tcl_TraceObjCmd, NULL, NULL, CMD_IS_SAFE}, {"try", Tcl_TryObjCmd, TclCompileTryCmd, TclNRTryObjCmd, CMD_IS_SAFE}, {"unset", Tcl_UnsetObjCmd, TclCompileUnsetCmd, NULL, CMD_IS_SAFE}, - {"uplevel", Tcl_UplevelObjCmd, NULL, TclNRUplevelObjCmd, CMD_IS_SAFE}, + {"uplevel", Tcl_UplevelObjCmd, TclCompileUplevelCmd, TclNRUplevelObjCmd, CMD_IS_SAFE}, {"upvar", Tcl_UpvarObjCmd, TclCompileUpvarCmd, NULL, CMD_IS_SAFE}, {"variable", Tcl_VariableObjCmd, TclCompileVariableCmd, NULL, CMD_IS_SAFE}, {"while", Tcl_WhileObjCmd, TclCompileWhileCmd, TclNRWhileObjCmd, CMD_IS_SAFE}, {"yield", NULL, TclCompileYieldCmd, TclNRYieldObjCmd, CMD_IS_SAFE}, - {"yieldto", NULL, TclCompileYieldToCmd, TclNRYieldToObjCmd, CMD_IS_SAFE}, + {"yieldto", NULL, TclCompileYieldToCmd, TclNRYieldToObjCmd, CMD_IS_SAFE|CMD_COMPILES_EXPANDED}, /* * Commands in the OS-interface. Note that many of these are unsafe. @@ -650,7 +647,7 @@ TclFinalizeEvaluation(void) /* *---------------------------------------------------------------------- * - * buildInfoObjCmd -- + * BuildInfoObjCmd -- * * Implements tcl::build-info command. * @@ -664,7 +661,7 @@ TclFinalizeEvaluation(void) */ static int -buildInfoObjCmd2( +BuildInfoObjCmd2( void *clientData, Tcl_Interp *interp, /* Current interpreter. */ Tcl_Size objc, /* Number of arguments. */ @@ -776,13 +773,13 @@ buildInfoObjCmd2( } static int -buildInfoObjCmd( +BuildInfoObjCmd( void *clientData, Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - return buildInfoObjCmd2(clientData, interp, objc, objv); + return BuildInfoObjCmd2(clientData, interp, objc, objv); } /* @@ -1325,9 +1322,9 @@ Tcl_CreateInterp(void) Tcl_PkgProvideEx(interp, "tcl", TCL_PATCH_LEVEL, &tclStubs); Tcl_CmdInfo info2; Tcl_Command buildInfoCmd = Tcl_CreateObjCommand(interp, "::tcl::build-info", - buildInfoObjCmd, (void *)version, NULL); + BuildInfoObjCmd, (void *)version, NULL); Tcl_GetCommandInfoFromToken(buildInfoCmd, &info2); - info2.objProc2 = buildInfoObjCmd2; + info2.objProc2 = BuildInfoObjCmd2; info2.objClientData2 = (void *)version; Tcl_SetCommandInfoFromToken(buildInfoCmd, &info2); @@ -1385,8 +1382,8 @@ TclRegisterCommandTypeName( int isNew; hPtr = Tcl_CreateHashEntry(&commandTypeTable, - implementationProc, &isNew); - Tcl_SetHashValue(hPtr, (void *) nameStr); + (void *)implementationProc, &isNew); + Tcl_SetHashValue(hPtr, nameStr); } else { hPtr = Tcl_FindHashEntry(&commandTypeTable, implementationProc); @@ -2717,14 +2714,14 @@ Tcl_CreateCommand( typedef struct { Tcl_ObjCmdProc2 *proc; - void *clientData; /* Arbitrary value to pass to proc function. */ + void *clientData; /* Arbitrary value to pass to proc function. */ Tcl_CmdDeleteProc *deleteProc; - void *deleteData; /* Arbitrary value to pass to deleteProc function. */ + void *deleteData; /* Arbitrary value to pass to deleteProc function. */ Tcl_ObjCmdProc2 *nreProc; } CmdWrapperInfo; static int -cmdWrapperProc( +CmdWrapperProc( void *clientData, Tcl_Interp *interp, int objc, @@ -2734,11 +2731,11 @@ cmdWrapperProc( if (objc < 0) { objc = -1; } - return info->proc(info->clientData, interp, objc, objv); + return info->proc(info->clientData, interp, (int)objc, objv); } static void -cmdWrapperDeleteProc( +CmdWrapperDeleteProc( void *clientData) { CmdWrapperInfo *info = (CmdWrapperInfo *) clientData; @@ -2774,8 +2771,8 @@ Tcl_CreateObjCommand2( info->deleteData = clientData; return Tcl_CreateObjCommand(interp, cmdName, - (proc ? cmdWrapperProc : NULL), - info, cmdWrapperDeleteProc); + (proc ? CmdWrapperProc : NULL), + info, CmdWrapperDeleteProc); } Tcl_Command @@ -3006,9 +3003,9 @@ TclCreateObjCommandInNs( int InvokeStringCommand( - void *clientData, /* Points to command's Command structure. */ + void *clientData, /* Points to command's Command structure. */ Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ + int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Command *cmdPtr = (Command *)clientData; @@ -3293,7 +3290,7 @@ Tcl_SetCommandInfo( */ static int -invokeObj2Command( +InvokeObj2Command( void *clientData, /* Points to command's Command structure. */ Tcl_Interp *interp, /* Current interpreter. */ Tcl_Size objc, /* Number of arguments. */ @@ -3315,7 +3312,7 @@ invokeObj2Command( } static int -cmdWrapper2Proc( +CmdWrapper2Proc( void *clientData, Tcl_Interp *interp, Tcl_Size objc, @@ -3357,10 +3354,10 @@ Tcl_SetCommandInfoFromToken( } cmdPtr->objClientData = infoPtr->objClientData; } - if (cmdPtr->deleteProc == cmdWrapperDeleteProc) { + if (cmdPtr->deleteProc == CmdWrapperDeleteProc) { CmdWrapperInfo *info = (CmdWrapperInfo *) cmdPtr->deleteData; if (infoPtr->objProc2 == NULL) { - info->proc = invokeObj2Command; + info->proc = InvokeObj2Command; info->clientData = cmdPtr; info->nreProc = NULL; } else { @@ -3373,14 +3370,14 @@ Tcl_SetCommandInfoFromToken( info->deleteProc = infoPtr->deleteProc; info->deleteData = infoPtr->deleteData; } else { - if ((infoPtr->objProc2 != NULL) && (infoPtr->objProc2 != cmdWrapper2Proc)) { + if ((infoPtr->objProc2 != NULL) && (infoPtr->objProc2 != CmdWrapper2Proc)) { CmdWrapperInfo *info = (CmdWrapperInfo *)Tcl_Alloc(sizeof(CmdWrapperInfo)); info->proc = infoPtr->objProc2; info->clientData = infoPtr->objClientData2; info->nreProc = NULL; info->deleteProc = infoPtr->deleteProc; info->deleteData = infoPtr->deleteData; - cmdPtr->deleteProc = cmdWrapperDeleteProc; + cmdPtr->deleteProc = CmdWrapperDeleteProc; cmdPtr->deleteData = info; } else { cmdPtr->deleteProc = infoPtr->deleteProc; @@ -3464,19 +3461,19 @@ Tcl_GetCommandInfoFromToken( infoPtr->objClientData = cmdPtr->objClientData; infoPtr->proc = cmdPtr->proc; infoPtr->clientData = cmdPtr->clientData; - if (cmdPtr->deleteProc == cmdWrapperDeleteProc) { + if (cmdPtr->deleteProc == CmdWrapperDeleteProc) { CmdWrapperInfo *info = (CmdWrapperInfo *)cmdPtr->deleteData; infoPtr->deleteProc = info->deleteProc; infoPtr->deleteData = info->deleteData; infoPtr->objProc2 = info->proc; infoPtr->objClientData2 = info->clientData; - if (cmdPtr->objProc == cmdWrapperProc) { + if (cmdPtr->objProc == CmdWrapperProc) { infoPtr->isNativeObjectProc = 2; } } else { infoPtr->deleteProc = cmdPtr->deleteProc; infoPtr->deleteData = cmdPtr->deleteData; - infoPtr->objProc2 = cmdWrapper2Proc; + infoPtr->objProc2 = CmdWrapper2Proc; infoPtr->objClientData2 = cmdPtr; } infoPtr->namespacePtr = (Tcl_Namespace *) cmdPtr->nsPtr; @@ -3550,7 +3547,6 @@ Tcl_GetCommandFullName( * not have been deleted. */ Tcl_Obj *objPtr) /* Points to the object onto which the * command's full name is appended. */ - { Interp *iPtr = (Interp *) interp; Command *cmdPtr = (Command *) command; @@ -3948,7 +3944,7 @@ CallCommandTraces( static int CancelEvalProc( - void *clientData, /* Interp to cancel the script in progress. */ + void *clientData, /* Interp to cancel the script in progress. */ TCL_UNUSED(Tcl_Interp *), int code) /* Current return code from command. */ { @@ -4438,7 +4434,7 @@ EvalObjvCore( TCL_UNUSED(int) /*result*/) { Command *cmdPtr = NULL, *preCmdPtr = (Command *)data[0]; - int flags = PTR2INT(data[1]); + int flags = (int)PTR2INT(data[1]); Tcl_Size objc = PTR2INT(data[2]); Tcl_Obj **objv = (Tcl_Obj **)data[3]; Interp *iPtr = (Interp *) interp; @@ -5158,7 +5154,7 @@ TclEvalEx( int flags, /* Collection of OR-ed bits that control the * evaluation of the script. Only * TCL_EVAL_GLOBAL is currently supported. */ - Tcl_Size line, /* The line the script starts on. */ + int line, /* The line the script starts on. */ Tcl_Size *clNextOuter, /* Information about an outer context for */ const char *outerScript) /* continuation line data. This is set only in * TclSubstTokens(), to properly handle @@ -5181,8 +5177,8 @@ TclEvalEx( const char *p, *next; const int minObjs = 20; Tcl_Obj **objv, **objvSpace; - int *expand; - Tcl_Size *lines, *lineSpace; + char *expand; + int *lines, *lineSpace; Tcl_Token *tokenPtr; int expandRequested, code = TCL_OK; Tcl_Size bytesLeft, commandLength; @@ -5198,8 +5194,8 @@ TclEvalEx( Tcl_Parse *parsePtr = (Tcl_Parse *)TclStackAlloc(interp, sizeof(Tcl_Parse)); CmdFrame *eeFramePtr = (CmdFrame *)TclStackAlloc(interp, sizeof(CmdFrame)); Tcl_Obj **stackObjArray = (Tcl_Obj **)TclStackAlloc(interp, minObjs * sizeof(Tcl_Obj *)); - int *expandStack = (int *)TclStackAlloc(interp, minObjs * sizeof(int)); - Tcl_Size *linesStack = (Tcl_Size *)TclStackAlloc(interp, minObjs * sizeof(Tcl_Size)); + char *expandStack = (char *)TclStackAlloc(interp, minObjs * sizeof(char)); + int *linesStack = (int *)TclStackAlloc(interp, minObjs * sizeof(int)); /* TIP #280 Structures for tracking of command * locations. */ Tcl_Size *clNext = NULL; /* Pointer for the tracking of invisible @@ -5324,7 +5320,7 @@ TclEvalEx( * per-command parsing. */ - Tcl_Size wordLine = line; + int wordLine = line; const char *wordStart = parsePtr->commandStart; Tcl_Size *wordCLNext = clNext; Tcl_Size objectsNeeded = 0; @@ -5335,11 +5331,11 @@ TclEvalEx( */ if (numWords > minObjs) { - expand = (int *)Tcl_Alloc(numWords * sizeof(int)); + expand = (char *)Tcl_Alloc(numWords * sizeof(char)); objvSpace = (Tcl_Obj **) Tcl_Alloc(numWords * sizeof(Tcl_Obj *)); - lineSpace = (Tcl_Size *) - Tcl_Alloc(numWords * sizeof(Tcl_Size)); + lineSpace = (int *) + Tcl_Alloc(numWords * sizeof(int)); } expandRequested = 0; objv = objvSpace; @@ -5431,13 +5427,13 @@ TclEvalEx( */ Tcl_Obj **copy = objvSpace; - Tcl_Size *lcopy = lineSpace; + int *lcopy = lineSpace; Tcl_Size wordIdx = numWords; Tcl_Size objIdx = objectsNeeded - 1; if ((numWords > minObjs) || (objectsNeeded > minObjs)) { objv = objvSpace = (Tcl_Obj **)Tcl_Alloc(objectsNeeded * sizeof(Tcl_Obj *)); - lines = lineSpace = (Tcl_Size *)Tcl_Alloc(objectsNeeded * sizeof(Tcl_Size)); + lines = lineSpace = (int *)Tcl_Alloc(objectsNeeded * sizeof(int)); } objectsUsed = 0; @@ -5576,7 +5572,7 @@ TclEvalEx( Tcl_LogCommandInfo(interp, script, parsePtr->commandStart, commandLength); } - posterror: + posterror: iPtr->flags &= ~ERR_ALREADY_LOGGED; /* @@ -5598,7 +5594,7 @@ TclEvalEx( } iPtr->varFramePtr = savedVarFramePtr; - cleanup_return: + cleanup_return: /* * TIP #280. Release the local CmdFrame, and its contents. */ @@ -5636,7 +5632,7 @@ TclEvalEx( void TclAdvanceLines( - Tcl_Size *line, + int *line, const char *start, const char *end) { @@ -5671,9 +5667,9 @@ TclAdvanceLines( void TclAdvanceContinuations( - Tcl_Size *line, + int *line, Tcl_Size **clNextPtrPtr, - int loc) + Tcl_Size loc) { /* * Track the invisible continuation lines embedded in a script, if any. @@ -5854,7 +5850,7 @@ TclArgumentBCEnter( Tcl_Size pc) { ExtCmdLoc *eclPtr; - Tcl_Size word; + int word; ECL *ePtr; CFWordBC *lastPtr = NULL; Interp *iPtr = (Interp *) interp; @@ -6126,7 +6122,7 @@ TclNREvalObjEx( * evaluation of the script. Supported values * are TCL_EVAL_GLOBAL and TCL_EVAL_DIRECT. */ const CmdFrame *invoker, /* Frame of the command doing the eval. */ - int word) /* Index of the word which is in objPtr. */ + int word) /* Index of the word which is in objPtr. */ { Interp *iPtr = (Interp *) interp; int result; @@ -6295,7 +6291,7 @@ TEOEx_ByteCodeCallback( Interp *iPtr = (Interp *) interp; CallFrame *savedVarFramePtr = (CallFrame *)data[0]; Tcl_Obj *objPtr = (Tcl_Obj *)data[1]; - int allowExceptions = PTR2INT(data[2]); + int allowExceptions = (int)PTR2INT(data[2]); if (iPtr->numLevels == 0) { if (result == TCL_RETURN) { @@ -6741,7 +6737,7 @@ TclNRInvoke( */ iPtr->numLevels++; - Tcl_NRAddCallback(interp, NRPostInvoke, NULL, NULL, NULL, NULL); + Tcl_NRAddCallback(interp, TclNRPostInvoke, NULL, NULL, NULL, NULL); /* * Normal command resolution of objv[0] isn't going to find cmdPtr. @@ -6752,8 +6748,8 @@ TclNRInvoke( return TclNREvalObjv(interp, objc, objv, TCL_EVAL_NORESOLVE, cmdPtr); } -static int -NRPostInvoke( +int +TclNRPostInvoke( TCL_UNUSED(void **), Tcl_Interp *interp, int result) @@ -7717,7 +7713,7 @@ ExprRandFunc( * take into consideration the thread this interp is running in. */ - iPtr->randSeed = TclpGetClicks() + PTR2UINT(Tcl_GetCurrentThread()) * 4093U; + iPtr->randSeed = (long)TclpGetClicks() + (long)PTR2UINT(Tcl_GetCurrentThread()) * 4093U; /* * Make sure 1 <= randSeed <= (2^31) - 2. See below. @@ -7772,7 +7768,7 @@ ExprRandFunc( * dividing by RAND_IM yields a double in the range (0, 1). */ - dResult = iPtr->randSeed * (1.0/RAND_IM); + dResult = (double)iPtr->randSeed * (1.0/RAND_IM); /* * Push a Tcl object with the result. @@ -8065,16 +8061,16 @@ DoubleObjClass( return TCL_ERROR; } switch (type) { - case TCL_NUMBER_NAN: + case TCL_NUMBER_NAN: *fpClsPtr = FP_NAN; return TCL_OK; - case TCL_NUMBER_DOUBLE: + case TCL_NUMBER_DOUBLE: d = *((const double *) ptr); break; - case TCL_NUMBER_INT: + case TCL_NUMBER_INT: d = (double)*((const Tcl_WideInt *) ptr); break; - default: + default: if (Tcl_GetDoubleFromObj(interp, objPtr, &d) != TCL_OK) { return TCL_ERROR; } @@ -8089,7 +8085,7 @@ DoubleObjIsClass( int objc, /* Actual parameter count */ Tcl_Obj *const *objv, /* Actual parameter list */ int cmpCls, /* FP class to compare. */ - int positive) /* 1 if compare positive, 0 - otherwise */ + int positive) /* 1 if compare positive, 0 - otherwise */ { int dCls; @@ -8180,10 +8176,8 @@ ExprIsUnorderedFunc( return TCL_ERROR; } - if ( - DoubleObjClass(interp, objv[1], &dCls) != TCL_OK || - DoubleObjClass(interp, objv[2], &dCls2) != TCL_OK - ) { + if (DoubleObjClass(interp, objv[1], &dCls) != TCL_OK || + DoubleObjClass(interp, objv[2], &dCls2) != TCL_OK) { return TCL_ERROR; } @@ -8264,8 +8258,8 @@ FloatClassifyObjCmd( static void MathFuncWrongNumArgs( Tcl_Interp *interp, /* Tcl interpreter */ - int expected, /* Formal parameter count. */ - int found, /* Actual parameter count. */ + Tcl_Size expected, /* Formal parameter count. */ + Tcl_Size found, /* Actual parameter count. */ Tcl_Obj *const *objv) /* Actual parameter vector. */ { const char *name = TclGetString(objv[0]); @@ -8463,7 +8457,7 @@ Tcl_NRCallObjProc( } static int -wrapperNRObjProc( +WrapperNRObjProc( void *clientData, Tcl_Interp *interp, int objc, @@ -8497,7 +8491,7 @@ Tcl_NRCallObjProc2( info->clientData = clientData; info->proc = objProc; - TclNRAddCallback(interp, Dispatch, wrapperNRObjProc, info, + TclNRAddCallback(interp, Dispatch, WrapperNRObjProc, info, INT2PTR(objc), objv); return TclNRRunCallbacks(interp, TCL_OK, rootPtr); } @@ -8531,7 +8525,7 @@ Tcl_NRCallObjProc2( */ static int -cmdWrapperNreProc( +CmdWrapperNreProc( void *clientData, Tcl_Interp *interp, int objc, @@ -8572,9 +8566,9 @@ Tcl_NRCreateCommand2( info->deleteProc = deleteProc; info->deleteData = clientData; return Tcl_NRCreateCommand(interp, cmdName, - (proc ? cmdWrapperProc : NULL), - (nreProc ? cmdWrapperNreProc : NULL), - info, cmdWrapperDeleteProc); + (proc ? CmdWrapperProc : NULL), + (nreProc ? CmdWrapperNreProc : NULL), + info, CmdWrapperDeleteProc); } Tcl_Command @@ -8820,6 +8814,7 @@ TclNRTailcallObjCmd( listPtr = Tcl_NewListObj(objc, objv); TclListObjSetElement(NULL, listPtr, 0, TclNewNamespaceObj(nsPtr)); + Tcl_IncrRefCount(listPtr); iPtr->varFramePtr->tailcallPtr = listPtr; } @@ -9611,8 +9606,8 @@ TclNRInterpCoroutine( break; default: if (corPtr->nargs + 1 != objc) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("wrong coro nargs; how did we get here? " + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "wrong coro nargs; how did we get here? " "not implemented!", TCL_INDEX_NONE)); Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", (char *)NULL); return TCL_ERROR; @@ -9711,11 +9706,10 @@ TclNRCoroutineObjCmd( for (hePtr = Tcl_FirstHashEntry(iPtr->lineLABCPtr,&hSearch); hePtr; hePtr = Tcl_NextHashEntry(&hSearch)) { - int isNew; Tcl_HashEntry *newPtr = Tcl_CreateHashEntry(corPtr->lineLABCPtr, Tcl_GetHashKey(iPtr->lineLABCPtr, hePtr), - &isNew); + NULL); Tcl_SetHashValue(newPtr, Tcl_GetHashValue(hePtr)); } diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 1e68415..ad50d29 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -384,7 +384,7 @@ Tcl_GetBytesFromObj( return baPtr->bytes; } -#if !defined(TCL_NO_DEPRECATED) +#ifndef TCL_NO_DEPRECATED unsigned char * TclGetBytesFromObj( Tcl_Interp *interp, /* For error reporting */ @@ -512,7 +512,7 @@ MakeByteArray( for (; src < srcEnd && dst < dstEnd; ) { int ch; - int count = TclUtfToUniChar(src, &ch); + Tcl_Size count = TclUtfToUniChar(src, &ch); if (ch > 255) { proper = 0; @@ -770,12 +770,9 @@ TclAppendBytesToByteArray( needed = byteArrayPtr->used + len; if (needed > byteArrayPtr->allocated) { Tcl_Size newCapacity; - byteArrayPtr = - (ByteArray *)TclReallocElemsEx(byteArrayPtr, - needed, - 1, - offsetof(ByteArray, bytes), - &newCapacity); + byteArrayPtr = (ByteArray *) + TclReallocElemsEx(byteArrayPtr, needed, 1, + offsetof(ByteArray, bytes), &newCapacity); byteArrayPtr->allocated = newCapacity; SET_BYTEARRAY(irPtr, byteArrayPtr); } @@ -1296,22 +1293,22 @@ BinaryFormatCmd( Tcl_SetObjResult(interp, resultPtr); return TCL_OK; - badValue: + badValue: Tcl_ResetResult(interp); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "expected %s string but got \"%s\" instead", errorString, errorValue)); return TCL_ERROR; - badCount: + badCount: errorString = "missing count for \"@\" field specifier"; goto error; - badIndex: + badIndex: errorString = "not enough arguments for all format specifiers"; goto error; - badField: + badField: { Tcl_UniChar ch = 0; char buf[5] = ""; @@ -1323,7 +1320,7 @@ BinaryFormatCmd( return TCL_ERROR; } - error: + error: Tcl_SetObjResult(interp, Tcl_NewStringObj(errorString, -1)); return TCL_ERROR; } @@ -1678,21 +1675,21 @@ BinaryScanCmd( * Set the result to the last position of the cursor. */ - done: + done: Tcl_SetObjResult(interp, Tcl_NewWideIntObj(arg - 3)); DeleteScanNumberCache(numberCachePtr); return TCL_OK; - badCount: + badCount: errorString = "missing count for \"@\" field specifier"; goto error; - badIndex: + badIndex: errorString = "not enough arguments for all format specifiers"; goto error; - badField: + badField: { Tcl_UniChar ch = 0; char buf[5] = ""; @@ -1704,7 +1701,7 @@ BinaryScanCmd( return TCL_ERROR; } - error: + error: Tcl_SetObjResult(interp, Tcl_NewStringObj(errorString, -1)); return TCL_ERROR; } @@ -2669,7 +2666,7 @@ BinaryEncode64( size = (((count * 4) / 3) + 3) & ~3; /* ensure 4 byte chunks */ if (maxlen > 0 && size > maxlen) { - int adjusted = size + (wrapcharlen * (size / maxlen)); + Tcl_Size adjusted = size + (wrapcharlen * (size / maxlen)); if (size % maxlen == 0) { adjusted -= wrapcharlen; @@ -2976,14 +2973,14 @@ BinaryDecodeUu( */ if (lineLen > 0) { - *cursor++ = (((d[0] - 0x20) & 0x3F) << 2) + *cursor++ = (unsigned char)(((d[0] - 0x20) & 0x3F) << 2) | (((d[1] - 0x20) & 0x3F) >> 4); if (--lineLen > 0) { - *cursor++ = (((d[1] - 0x20) & 0x3F) << 4) + *cursor++ = (unsigned char)(((d[1] - 0x20) & 0x3F) << 4) | (((d[2] - 0x20) & 0x3F) >> 2); if (--lineLen > 0) { - *cursor++ = (((d[2] - 0x20) & 0x3F) << 6) - | (((d[3] - 0x20) & 0x3F)); + *cursor++ = (unsigned char)((((d[2] - 0x20) & 0x3F) << 6) + | (((d[3] - 0x20) & 0x3F))); lineLen--; } } diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c index bf2b12c..a391efd 100644 --- a/generic/tclCkalloc.c +++ b/generic/tclCkalloc.c @@ -276,7 +276,6 @@ ValidateMemory( memset(memHeaderP->low_guard, 0, LOW_GUARD_SIZE); memset(hiPtr, 0, HIGH_GUARD_SIZE); } - } /* @@ -813,7 +812,8 @@ MemoryCmd( return TCL_ERROR; } - if (strcmp(TclGetString(objv[1]), "active") == 0 || strcmp(TclGetString(objv[1]), "display") == 0) { + if (strcmp(TclGetString(objv[1]), "active") == 0 || + strcmp(TclGetString(objv[1]), "display") == 0) { if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "file"); return TCL_ERROR; @@ -1257,12 +1257,11 @@ TclAllocElemsEx( * non-NULL. Only modified on success */ { void *ptr = TclAttemptReallocElemsEx( - NULL, elemCount, elemSize, leadSize, capacityPtr); + NULL, elemCount, elemSize, leadSize, capacityPtr); if (ptr == NULL) { Tcl_Panic("Failed to allocate %" TCL_SIZE_MODIFIER - "d elements of size %" TCL_SIZE_MODIFIER "d bytes.", - elemCount, - elemSize); + "d elements of size %" TCL_SIZE_MODIFIER "d bytes.", + elemCount, elemSize); } return ptr; } @@ -1363,12 +1362,11 @@ TclReallocElemsEx( * non-NULL. Only modified on success */ { void *ptr = TclAttemptReallocElemsEx( - oldPtr, elemCount, elemSize, leadSize, capacityPtr); + oldPtr, elemCount, elemSize, leadSize, capacityPtr); if (ptr == NULL) { Tcl_Panic("Failed to reallocate %" TCL_SIZE_MODIFIER - "d elements of size %" TCL_SIZE_MODIFIER "d bytes.", - elemCount, - elemSize); + "d elements of size %" TCL_SIZE_MODIFIER "d bytes.", + elemCount, elemSize); } return ptr; } diff --git a/generic/tclClock.c b/generic/tclClock.c index 1f7a1db..46af704 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -129,10 +129,10 @@ static const struct ClockCommand clockCommands[] = { {"clicks", ClockClicksObjCmd, TclCompileClockClicksCmd, NULL}, {"format", ClockFormatObjCmd, TclCompileBasicMin1ArgCmd, NULL}, {"getenv", ClockGetenvObjCmd, TclCompileBasicMin1ArgCmd, NULL}, - {"microseconds", ClockMicrosecondsObjCmd,TclCompileClockReadingCmd, INT2PTR(1)}, - {"milliseconds", ClockMillisecondsObjCmd,TclCompileClockReadingCmd, INT2PTR(2)}, + {"microseconds", ClockMicrosecondsObjCmd,TclCompileClockReadingCmd, INT2PTR(CLOCK_READ_MICROS)}, + {"milliseconds", ClockMillisecondsObjCmd,TclCompileClockReadingCmd, INT2PTR(CLOCK_READ_MILLIS)}, {"scan", ClockScanObjCmd, TclCompileBasicMin1ArgCmd, NULL}, - {"seconds", ClockSecondsObjCmd, TclCompileClockReadingCmd, INT2PTR(3)}, + {"seconds", ClockSecondsObjCmd, TclCompileClockReadingCmd, INT2PTR(CLOCK_READ_SECS)}, {"ConvertLocalToUTC", ClockConvertlocaltoutcObjCmd, NULL, NULL}, {"GetDateFields", ClockGetdatefieldsObjCmd, NULL, NULL}, {"GetJulianDayFromEraYearMonthDay", @@ -3484,7 +3484,7 @@ ClockParseFmtScnArgs( /* extact fields from base */ date->seconds = baseVal; if (ClockGetDateFields(dataPtr, interp, date, opts->timezoneObj, - GREGORIAN_CHANGE_DATE) != TCL_OK) { + GREGORIAN_CHANGE_DATE) != TCL_OK) { /* TODO - GREGORIAN_CHANGE_DATE should be locale-dependent */ return TCL_ERROR; } @@ -4276,7 +4276,7 @@ ClockCalcRelTime( yyRelSeconds = 0; /* Convert it back */ if (ClockGetDateFields(opts->dataPtr, opts->interp, &yydate, - opts->timezoneObj, GREGORIAN_CHANGE_DATE) != TCL_OK) { + opts->timezoneObj, GREGORIAN_CHANGE_DATE) != TCL_OK) { /* TODO - GREGORIAN_CHANGE_DATE should be locale-dependent */ return TCL_ERROR; } @@ -4719,11 +4719,7 @@ ClockSafeCatchCmd( typedef struct ClockTzStatic { WCHAR *was; /* Previous value of TZ. */ -#if TCL_MAJOR_VERSION > 8 long long lastRefresh; /* Used for latency before next refresh. */ -#else - long lastRefresh; /* Used for latency before next refresh. */ -#endif size_t epoch; /* Epoch, signals that TZ changed. */ size_t envEpoch; /* Last env epoch, for faster signaling, * that TZ changed via TCL */ diff --git a/generic/tclClockFmt.c b/generic/tclClockFmt.c index 7819ee5..d531108 100644 --- a/generic/tclClockFmt.c +++ b/generic/tclClockFmt.c @@ -844,7 +844,7 @@ FindOrCreateFmtScnStorage( } /* get or create entry (and alocate storage) */ - hPtr = Tcl_CreateHashEntry(&FmtScnHashTable, strFmt, &isNew); + hPtr = Tcl_AttemptCreateHashEntry(&FmtScnHashTable, strFmt, &isNew); if (hPtr != NULL) { fss = FmtScn4HashEntry(hPtr); diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 59a30d2..5183ced 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -528,7 +528,7 @@ EncodingConvertfromObjCmd( Tcl_Obj *data; /* Byte array to convert */ Tcl_DString ds; /* Buffer to hold the string */ Tcl_Encoding encoding; /* Encoding to use */ - Tcl_Size length = 0; /* Length of the byte array being converted */ + Tcl_Size length = 0; /* Length of the byte array being converted */ const char *bytesPtr; /* Pointer to the first byte of the array */ int flags; int result; @@ -694,7 +694,6 @@ done: Tcl_FreeEncoding(encoding); } return result; - } /* @@ -760,9 +759,9 @@ EncodingDirsObjCmd( int EncodingNamesObjCmd( TCL_UNUSED(void *), - Tcl_Interp* interp, /* Tcl interpreter */ - int objc, /* Number of command line args */ - Tcl_Obj* const objv[]) /* Vector of command line args */ + Tcl_Interp* interp, /* Tcl interpreter */ + int objc, /* Number of command line args */ + Tcl_Obj* const objv[]) /* Vector of command line args */ { if (objc > 1) { Tcl_WrongNumArgs(interp, 1, objv, NULL); @@ -2378,34 +2377,30 @@ StoreStatData( * store in varName. */ { Tcl_Obj *field, *value, *result; - unsigned short mode; + unsigned short modeVal = (unsigned short) statPtr->st_mode; if (varName == NULL) { TclNewObj(result); Tcl_IncrRefCount(result); -#define DOBJPUT(key, objValue) \ - Tcl_DictObjPut(NULL, result, \ - Tcl_NewStringObj((key), -1), \ - (objValue)); - DOBJPUT("dev", Tcl_NewWideIntObj((long)statPtr->st_dev)); - DOBJPUT("ino", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_ino)); - DOBJPUT("nlink", Tcl_NewWideIntObj((long)statPtr->st_nlink)); - DOBJPUT("uid", Tcl_NewWideIntObj((long)statPtr->st_uid)); - DOBJPUT("gid", Tcl_NewWideIntObj((long)statPtr->st_gid)); - DOBJPUT("size", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_size)); +#define D_PUT(key, objValue) TclDictPut(NULL, result, #key, (objValue)) + D_PUT(dev, Tcl_NewWideIntObj((long)statPtr->st_dev)); + D_PUT(ino, Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_ino)); + D_PUT(nlink, Tcl_NewWideIntObj((long)statPtr->st_nlink)); + D_PUT(uid, Tcl_NewWideIntObj((long)statPtr->st_uid)); + D_PUT(gid, Tcl_NewWideIntObj((long)statPtr->st_gid)); + D_PUT(size, Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_size)); #ifdef HAVE_STRUCT_STAT_ST_BLOCKS - DOBJPUT("blocks", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_blocks)); + D_PUT(blocks, Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_blocks)); #endif #ifdef HAVE_STRUCT_STAT_ST_BLKSIZE - DOBJPUT("blksize", Tcl_NewWideIntObj((long)statPtr->st_blksize)); + D_PUT(blksize, Tcl_NewWideIntObj((long)statPtr->st_blksize)); #endif - DOBJPUT("atime", Tcl_NewWideIntObj(Tcl_GetAccessTimeFromStat(statPtr))); - DOBJPUT("mtime", Tcl_NewWideIntObj(Tcl_GetModificationTimeFromStat(statPtr))); - DOBJPUT("ctime", Tcl_NewWideIntObj(Tcl_GetChangeTimeFromStat(statPtr))); - mode = (unsigned short) statPtr->st_mode; - DOBJPUT("mode", Tcl_NewWideIntObj(mode)); - DOBJPUT("type", Tcl_NewStringObj(GetTypeFromMode(mode), -1)); -#undef DOBJPUT + D_PUT(atime, Tcl_NewWideIntObj(Tcl_GetAccessTimeFromStat(statPtr))); + D_PUT(mtime, Tcl_NewWideIntObj(Tcl_GetModificationTimeFromStat(statPtr))); + D_PUT(ctime, Tcl_NewWideIntObj(Tcl_GetChangeTimeFromStat(statPtr))); + D_PUT(mode, Tcl_NewWideIntObj(modeVal)); + D_PUT(type, Tcl_NewStringObj(GetTypeFromMode(modeVal), -1)); +#undef D_PUT Tcl_SetObjResult(interp, result); Tcl_DecrRefCount(result); return TCL_OK; @@ -2418,44 +2413,45 @@ StoreStatData( */ #define STORE_ARY(fieldName, object) \ - TclNewLiteralStringObj(field, fieldName); \ - Tcl_IncrRefCount(field); \ - value = (object); \ - if (Tcl_ObjSetVar2(interp,varName,field,value,TCL_LEAVE_ERR_MSG)==NULL) { \ + do { \ + TclNewLiteralStringObj(field, #fieldName); \ + Tcl_IncrRefCount(field); \ + value = (object); \ + if (Tcl_ObjSetVar2(interp, varName, field, value, \ + TCL_LEAVE_ERR_MSG) == NULL) { \ + TclDecrRefCount(field); \ + return TCL_ERROR; \ + } \ TclDecrRefCount(field); \ - return TCL_ERROR; \ - } \ - TclDecrRefCount(field); + } while (0) /* * Watch out porters; the inode is meant to be an *unsigned* value, so the * cast might fail when there isn't a real arithmetic 'long long' type... */ - STORE_ARY("dev", Tcl_NewWideIntObj((long)statPtr->st_dev)); - STORE_ARY("ino", Tcl_NewWideIntObj(statPtr->st_ino)); - STORE_ARY("nlink", Tcl_NewWideIntObj((long)statPtr->st_nlink)); - STORE_ARY("uid", Tcl_NewWideIntObj((long)statPtr->st_uid)); - STORE_ARY("gid", Tcl_NewWideIntObj((long)statPtr->st_gid)); - STORE_ARY("size", Tcl_NewWideIntObj(statPtr->st_size)); + STORE_ARY(dev, Tcl_NewWideIntObj((long)statPtr->st_dev)); + STORE_ARY(ino, Tcl_NewWideIntObj(statPtr->st_ino)); + STORE_ARY(nlink, Tcl_NewWideIntObj((long)statPtr->st_nlink)); + STORE_ARY(uid, Tcl_NewWideIntObj((long)statPtr->st_uid)); + STORE_ARY(gid, Tcl_NewWideIntObj((long)statPtr->st_gid)); + STORE_ARY(size, Tcl_NewWideIntObj(statPtr->st_size)); #ifdef HAVE_STRUCT_STAT_ST_BLOCKS - STORE_ARY("blocks", Tcl_NewWideIntObj(statPtr->st_blocks)); + STORE_ARY(blocks, Tcl_NewWideIntObj(statPtr->st_blocks)); #endif #ifdef HAVE_STRUCT_STAT_ST_BLKSIZE - STORE_ARY("blksize", Tcl_NewWideIntObj((long)statPtr->st_blksize)); + STORE_ARY(blksize, Tcl_NewWideIntObj((long)statPtr->st_blksize)); #endif #ifdef HAVE_STRUCT_STAT_ST_RDEV if (S_ISCHR(statPtr->st_mode) || S_ISBLK(statPtr->st_mode)) { STORE_ARY("rdev", Tcl_NewWideIntObj((long) statPtr->st_rdev)); } #endif - STORE_ARY("atime", Tcl_NewWideIntObj(Tcl_GetAccessTimeFromStat(statPtr))); - STORE_ARY("mtime", Tcl_NewWideIntObj( - Tcl_GetModificationTimeFromStat(statPtr))); - STORE_ARY("ctime", Tcl_NewWideIntObj(Tcl_GetChangeTimeFromStat(statPtr))); - mode = (unsigned short) statPtr->st_mode; - STORE_ARY("mode", Tcl_NewWideIntObj(mode)); - STORE_ARY("type", Tcl_NewStringObj(GetTypeFromMode(mode), -1)); + STORE_ARY(atime, Tcl_NewWideIntObj(Tcl_GetAccessTimeFromStat(statPtr))); + STORE_ARY(mtime, Tcl_NewWideIntObj(Tcl_GetModificationTimeFromStat(statPtr))); + STORE_ARY(ctime, Tcl_NewWideIntObj(Tcl_GetChangeTimeFromStat(statPtr))); + STORE_ARY(mode, Tcl_NewWideIntObj(modeVal)); + STORE_ARY(type, Tcl_NewStringObj(GetTypeFromMode(modeVal), -1)); #undef STORE_ARY return TCL_OK; diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index b3d5fe9..5e732c5 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -818,7 +818,7 @@ InfoCommandsCmd( elemObjPtr = Tcl_NewStringObj(cmdName, -1); Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); (void) Tcl_CreateHashEntry(&addedCommandsTable, - elemObjPtr, &isNew); + elemObjPtr, NULL); } entryPtr = Tcl_NextHashEntry(&search); } @@ -1259,7 +1259,7 @@ TclInfoFrame( { Interp *iPtr = (Interp *) interp; Tcl_Obj *tmpObj; - Tcl_Obj *lv[20] = {NULL}; /* Keep uptodate when more keys are added to + Tcl_Obj *lv[20] = {NULL}; /* Keep uptodate when more keys are added to * the dict. */ int lc = 0; /* @@ -1304,7 +1304,7 @@ TclInfoFrame( break; case TCL_LOCATION_PREBC: - precompiled: + precompiled: /* * Precompiled. Result contains the type as signal, nothing else. */ @@ -1607,7 +1607,7 @@ InfoLevelCmd( } for (framePtr=iPtr->varFramePtr ; framePtr!=rootFramePtr; framePtr=framePtr->callerVarPtr) { - if ((int)framePtr->level == level) { + if (framePtr->level == level) { break; } } @@ -2327,22 +2327,14 @@ Tcl_LassignObjCmd( } if (listObjc > 0) { - Tcl_Obj *resultObjPtr = NULL; - Tcl_Size fromIdx = origListObjc - listObjc; - Tcl_Size toIdx = origListObjc - 1; - if (TclObjTypeHasProc(listPtr, sliceProc)) { - if (TclObjTypeSlice( - interp, listPtr, fromIdx, toIdx, &resultObjPtr) != TCL_OK) { - return TCL_ERROR; - } - } else { - resultObjPtr = TclListObjRange( - interp, listPtr, origListObjc - listObjc, origListObjc - 1); - if (resultObjPtr == NULL) { - return TCL_ERROR; - } + Tcl_Obj *resultObj = NULL; + Tcl_Size first = origListObjc - listObjc; + Tcl_Size last = origListObjc - 1; + int result = Tcl_ListObjRange(interp, listPtr, first, last, &resultObj); + if (result != TCL_OK) { + return result; } - Tcl_SetObjResult(interp, resultObjPtr); + Tcl_SetObjResult(interp, resultObj); } return TCL_OK; @@ -2427,7 +2419,7 @@ int Tcl_LinsertObjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ + int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Obj *listPtr; @@ -2520,9 +2512,8 @@ int Tcl_ListObjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) - /* The argument objects. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* The argument objects. */ { /* * If there are no list elements, the result is an empty object. @@ -2557,8 +2548,7 @@ Tcl_LlengthObjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) - /* Argument objects. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Size listLen; int result; @@ -2606,8 +2596,7 @@ Tcl_LpopObjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) - /* Argument objects. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Size listLen; int copied = 0, result; @@ -2725,8 +2714,7 @@ Tcl_LrangeObjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) - /* Argument objects. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { int result; Tcl_Size listLen, first, last; @@ -2752,22 +2740,12 @@ Tcl_LrangeObjCmd( return result; } - if (TclObjTypeHasProc(objv[1], sliceProc)) { - Tcl_Obj *resultObj; - int status = TclObjTypeSlice(interp, objv[1], first, last, &resultObj); - if (status == TCL_OK) { - Tcl_SetObjResult(interp, resultObj); - } else { - return TCL_ERROR; - } - } else { - Tcl_Obj *resultObj = TclListObjRange(interp, objv[1], first, last); - if (resultObj == NULL) { - return TCL_ERROR; - } + Tcl_Obj *resultObj; + result = Tcl_ListObjRange(interp, objv[1], first, last, &resultObj); + if (result == TCL_OK) { Tcl_SetObjResult(interp, resultObj); } - return TCL_OK; + return result; } /* @@ -2937,96 +2915,27 @@ int Tcl_LrepeatObjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) - /* The argument objects. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* The argument objects. */ { - Tcl_WideInt elementCount, i; - Tcl_Size totalElems; - Tcl_Obj *listPtr, **dataArray = NULL; - - /* - * Check arguments for legality: - * lrepeat count ?value ...? - */ + Tcl_Size repeatCount; + Tcl_Obj *resultPtr; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "count ?value ...?"); return TCL_ERROR; } - if (TCL_OK != TclGetWideIntFromObj(interp, objv[1], &elementCount)) { - return TCL_ERROR; - } - if (elementCount < 0) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad count \"%" TCL_LL_MODIFIER "d\": must be integer >= 0", elementCount)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LREPEAT", "NEGARG", - (char *)NULL); - return TCL_ERROR; - } - - /* - * Skip forward to the interesting arguments now we've finished parsing. - */ - - objc -= 2; - objv += 2; - /* Final sanity check. Do not exceed limits on max list length. */ - - if (elementCount && objc > LIST_MAX/elementCount) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "max length of a Tcl list (%" TCL_SIZE_MODIFIER "d elements) exceeded", LIST_MAX)); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL); + if (Tcl_GetSizeIntFromObj(interp, objv[1], &repeatCount) != TCL_OK) { return TCL_ERROR; } - totalElems = objc * elementCount; - - /* - * Get an empty list object that is allocated large enough to hold each - * init value elementCount times. - */ - - listPtr = Tcl_NewListObj(totalElems, NULL); - if (totalElems) { - ListRep listRep; - ListObjGetRep(listPtr, &listRep); - dataArray = ListRepElementsBase(&listRep); - listRep.storePtr->numUsed = totalElems; - if (listRep.spanPtr) { - /* Future proofing in case Tcl_NewListObj returns a span */ - listRep.spanPtr->spanStart = listRep.storePtr->firstUsed; - listRep.spanPtr->spanLength = listRep.storePtr->numUsed; - } - } - - /* - * Set the elements. Note that we handle the common degenerate case of a - * single value being repeated separately to permit the compiler as much - * room as possible to optimize a loop that might be run a very large - * number of times. - */ - - CLANG_ASSERT(dataArray || totalElems == 0 ); - if (objc == 1) { - Tcl_Obj *tmpPtr = objv[0]; - - tmpPtr->refCount += elementCount; - for (i=0 ; i<elementCount ; i++) { - dataArray[i] = tmpPtr; - } - } else { - Tcl_Size j, k = 0; - for (i=0 ; i<elementCount ; i++) { - for (j=0 ; j<objc ; j++) { - Tcl_IncrRefCount(objv[j]); - dataArray[k++] = objv[j]; - } - } + if (Tcl_ListObjRepeat( + interp, repeatCount, objc - 2, objv + 2, &resultPtr) != TCL_OK) { + return TCL_ERROR; } - Tcl_SetObjResult(interp, listPtr); + Tcl_SetObjResult(interp, resultPtr); return TCL_OK; } @@ -3157,82 +3066,16 @@ Tcl_LreverseObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument values. */ { - Tcl_Obj **elemv; - Tcl_Size elemc, i, j; - if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "list"); return TCL_ERROR; } - /* - * Handle AbstractList special case - do not shimmer into a list, if it - * supports a private Reverse function, just to reverse it. - */ - if (TclObjTypeHasProc(objv[1], reverseProc)) { - Tcl_Obj *resultObj; - - if (TclObjTypeReverse(interp, objv[1], &resultObj) == TCL_OK) { - Tcl_SetObjResult(interp, resultObj); - return TCL_OK; - } - } /* end Abstract List */ - - if (TclListObjLength(interp, objv[1], &elemc) != TCL_OK) { + Tcl_Obj *resultObj = NULL; + if (Tcl_ListObjReverse(interp, objv[1], &resultObj) != TCL_OK) { return TCL_ERROR; } - - /* - * If the list is empty, just return it. [Bug 1876793] - */ - - if (!elemc) { - Tcl_SetObjResult(interp, objv[1]); - return TCL_OK; - } - if (TclListObjGetElements(interp, objv[1], &elemc, &elemv) != TCL_OK) { - return TCL_ERROR; - } - - if (Tcl_IsShared(objv[1]) - || ListObjRepIsShared(objv[1])) { /* Bug 1675044 */ - Tcl_Obj *resultObj, **dataArray; - ListRep listRep; - - resultObj = Tcl_NewListObj(elemc, NULL); - - /* Modify the internal rep in-place */ - ListObjGetRep(resultObj, &listRep); - listRep.storePtr->numUsed = elemc; - dataArray = ListRepElementsBase(&listRep); - if (listRep.spanPtr) { - /* Future proofing */ - listRep.spanPtr->spanStart = listRep.storePtr->firstUsed; - listRep.spanPtr->spanLength = listRep.storePtr->numUsed; - } - - for (i=0,j=elemc-1 ; i<elemc ; i++,j--) { - dataArray[j] = elemv[i]; - Tcl_IncrRefCount(elemv[i]); - } - - Tcl_SetObjResult(interp, resultObj); - } else { - - /* - * Not shared, so swap "in place". This relies on Tcl_LOGE above - * returning a pointer to the live array of Tcl_Obj values. - */ - - for (i=0,j=elemc-1 ; i<j ; i++,j--) { - Tcl_Obj *tmp = elemv[i]; - - elemv[i] = elemv[j]; - elemv[j] = tmp; - } - TclInvalidateStringRep(objv[1]); - Tcl_SetObjResult(interp, objv[1]); - } + Tcl_SetObjResult(interp, resultObj); return TCL_OK; } @@ -3509,6 +3352,8 @@ Tcl_LsearchObjCmd( } break; } + default: + TCL_UNREACHABLE(); } } @@ -3929,7 +3774,7 @@ Tcl_LsearchObjCmd( } else if (returnSubindices && (sortInfo.indexc == 0) && (groupSize > 1)) { Tcl_BounceRefCount(itemPtr); itemPtr = listv[i + groupOffset]; - Tcl_ListObjAppendElement(interp, listPtr, itemPtr); + Tcl_ListObjAppendElement(interp, listPtr, itemPtr); } else if (groupSize > 1) { Tcl_ListObjReplace(interp, listPtr, LIST_MAX, 0, groupSize, &listv[i]); @@ -3977,8 +3822,8 @@ Tcl_LsearchObjCmd( } Tcl_SetObjResult(interp, itemPtr); } else { - Tcl_Obj *elObj; - TclNewIndexObj(elObj, index); + Tcl_Obj *elObj; + TclNewIndexObj(elObj, index); Tcl_SetObjResult(interp, elObj); } } else if (index < 0) { @@ -4037,11 +3882,11 @@ Tcl_LsearchObjCmd( static SequenceDecoded SequenceIdentifyArgument( - Tcl_Interp *interp, /* for error reporting */ - Tcl_Obj *argPtr, /* Argument to decode */ + Tcl_Interp *interp, /* for error reporting */ + Tcl_Obj *argPtr, /* Argument to decode */ int allowedArgs, /* Flags if keyword or numeric allowed. */ - Tcl_Obj **numValuePtr, /* Return numeric value */ - int *keywordIndexPtr) /* Return keyword enum */ + Tcl_Obj **numValuePtr, /* Return numeric value */ + int *keywordIndexPtr) /* Return keyword enum */ { int result = TCL_ERROR; SequenceOperators opmode; @@ -4050,7 +3895,7 @@ SequenceIdentifyArgument( if (allowedArgs & NumericArg) { /* speed-up a bit (and avoid shimmer for compiled expressions) */ if (TclHasInternalRep(argPtr, &tclExprCodeType)) { - goto doExpr; + goto doExpr; } result = Tcl_GetNumberFromObj(NULL, argPtr, &internalPtr, keywordIndexPtr); if (result == TCL_OK) { @@ -4061,13 +3906,13 @@ SequenceIdentifyArgument( } if (allowedArgs & RangeKeywordArg) { result = Tcl_GetIndexFromObj(NULL, argPtr, seq_operations, - "range operation", 0, &opmode); + "range operation", 0, &opmode); } if (result == TCL_OK) { if (allowedArgs & LastArg) { /* keyword found, but no followed number */ Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "missing \"%s\" value.", TclGetString(argPtr))); + "missing \"%s\" value.", TclGetString(argPtr))); return ErrArg; } *keywordIndexPtr = opmode; @@ -4085,8 +3930,7 @@ SequenceIdentifyArgument( int keyword; /* Determine if result of expression is double or int */ if (Tcl_GetNumberFromObj(interp, exprValueObj, &internalPtr, - &keyword) != TCL_OK - ) { + &keyword) != TCL_OK) { return ErrArg; } *numValuePtr = exprValueObj; /* incremented in Tcl_ExprObj */ @@ -4134,9 +3978,9 @@ SequenceIdentifyArgument( int Tcl_LseqObjCmd( TCL_UNUSED(void *), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* The argument objects. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* The argument objects. */ { Tcl_Obj *elementCount = NULL; Tcl_Obj *start = NULL, *end = NULL, *step = NULL; @@ -4151,8 +3995,8 @@ Tcl_LseqObjCmd( SequenceDecoded decoded; int i, arg_key = 0, value_i = 0; /* Default constants */ - #define zero ((Interp *)interp)->execEnvPtr->constants[0]; - #define one ((Interp *)interp)->execEnvPtr->constants[1]; +#define zero ((Interp *)interp)->execEnvPtr->constants[0]; +#define one ((Interp *)interp)->execEnvPtr->constants[1]; /* * Create a decoding key by looping through the arguments and identify @@ -4167,19 +4011,19 @@ Tcl_LseqObjCmd( arg_key = (arg_key * 10); numValues[value_i] = NULL; decoded = SequenceIdentifyArgument(interp, objv[i], - allowedArgs | (i == objc-1 ? LastArg : 0), - &numberObj, &keyword); + allowedArgs | (i == objc-1 ? LastArg : 0), + &numberObj, &keyword); switch (decoded) { - case NoneArg: + case NoneArg: /* * Unrecognizable argument * Reproduce operation error message */ status = Tcl_GetIndexFromObj(interp, objv[i], seq_operations, - "operation", 0, &opmode); + "operation", 0, &opmode); goto done; - case NumericArg: + case NumericArg: remNums--; arg_key += NumericArg; allowedArgs = RangeKeywordArg; @@ -4195,14 +4039,14 @@ Tcl_LseqObjCmd( value_i++; break; - case RangeKeywordArg: + case RangeKeywordArg: arg_key += RangeKeywordArg; allowedArgs = NumericArg; /* after keyword always numeric only */ values[value_i] = keyword; /* SequenceOperators */ value_i++; break; - default: /* Error state */ + default: /* Error state */ status = TCL_ERROR; goto done; } @@ -4284,10 +4128,8 @@ Tcl_LseqObjCmd( case LSEQ_BY: /* Error case */ goto syntax; - break; default: goto syntax; - break; } break; @@ -4305,7 +4147,6 @@ Tcl_LseqObjCmd( case LSEQ_COUNT: default: goto syntax; - break; } break; @@ -4320,7 +4161,6 @@ Tcl_LseqObjCmd( break; default: goto syntax; - break; } opmode = (SequenceOperators)values[1]; switch (opmode) { @@ -4335,16 +4175,14 @@ Tcl_LseqObjCmd( break; default: goto syntax; - break; } break; /* All other argument errors */ default: - syntax: - Tcl_WrongNumArgs(interp, 1, objv, "n ??op? n ??by? n??"); - goto done; - break; + syntax: + Tcl_WrongNumArgs(interp, 1, objv, "n ??op? n ??by? n??"); + goto done; } /* Count needs to be integer, so try to convert if possible */ @@ -4373,7 +4211,7 @@ Tcl_LseqObjCmd( * Success! Now lets create the series object. */ arithSeriesPtr = TclNewArithSeriesObj(interp, - useDoubles, start, end, step, elementCount); + useDoubles, start, end, step, elementCount); status = TCL_ERROR; if (arithSeriesPtr) { @@ -4381,7 +4219,7 @@ Tcl_LseqObjCmd( Tcl_SetObjResult(interp, arithSeriesPtr); } - done: + done: // Free number arguments. while (--value_i>=0) { if (numValues[value_i]) { @@ -4396,8 +4234,8 @@ Tcl_LseqObjCmd( } /* Undef constants */ - #undef zero - #undef one +#undef zero +#undef one return status; } @@ -4458,13 +4296,13 @@ Tcl_LsetObjCmd( } else { if (TclObjTypeHasProc(listPtr, setElementProc)) { finalValuePtr = TclObjTypeSetElement(interp, listPtr, - objc-3, objv+2, objv[objc-1]); + objc-3, objv+2, objv[objc-1]); if (finalValuePtr) { Tcl_IncrRefCount(finalValuePtr); } } else { finalValuePtr = TclLsetFlat(interp, listPtr, objc-3, objv+2, - objv[objc-1]); + objv[objc-1]); } } @@ -4690,6 +4528,8 @@ Tcl_LsortObjCmd( group = 1; i++; break; + default: + TCL_UNREACHABLE(); } } if (nocase && (sortInfo.sortMode == SORTMODE_ASCII)) { @@ -5362,7 +5202,7 @@ DictionaryCompare( int secondaryDiff = 0; while (1) { - if (isdigit(UCHAR(*right)) /* INTL: digit */ + if (isdigit(UCHAR(*right)) /* INTL: digit */ && isdigit(UCHAR(*left))) { /* INTL: digit */ /* * There are decimal numbers embedded in the two strings. Compare diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 22329fe..439d05c 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -132,7 +132,8 @@ Tcl_RegexpObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Size offset, stringLength, matchLength, cflags, eflags; - int i, indices, match, about, all, doinline, numMatchesSaved; + Tcl_Size i; + int indices, match, about, all, doinline, numMatchesSaved; Tcl_RegExp regExpr; Tcl_Obj *objPtr, *startIndex = NULL, *resultPtr = NULL; Tcl_RegExpInfo info; @@ -377,7 +378,7 @@ Tcl_RegexpObjCmd( * area. (Scriptics Bug 4391/SF Bug #219232) */ - if (i <= (int)info.nsubs && info.matches[i].start >= 0) { + if (i <= info.nsubs && info.matches[i].start >= 0) { start = offset + info.matches[i].start; end = offset + info.matches[i].end; @@ -399,7 +400,7 @@ Tcl_RegexpObjCmd( newPtr = Tcl_NewListObj(2, objs); } else { - if ((i <= (int)info.nsubs) && (info.matches[i].end > 0)) { + if ((i <= info.nsubs) && (info.matches[i].end > 0)) { newPtr = Tcl_GetRange(objPtr, offset + info.matches[i].start, offset + info.matches[i].end - 1); @@ -1912,7 +1913,7 @@ StringIsCmd( * valid fail index (>= 0). */ - str_is_done: + str_is_done: if ((result == 0) && (failVarObj != NULL)) { TclNewIndexObj(objPtr, failat); if (Tcl_ObjSetVar2(interp, failVarObj, NULL, objPtr, TCL_LEAVE_ERR_MSG) == NULL) { @@ -2048,8 +2049,8 @@ StringMapCmd( * The charMap must be an even number of key/value items. */ - Tcl_SetObjResult(interp, - Tcl_NewStringObj("char map list unbalanced", -1)); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "char map list unbalanced", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "MAP", "UNBALANCED", (char *)NULL); return TCL_ERROR; @@ -3345,12 +3346,18 @@ TclSubstOptions( int *flagPtr) { static const char *const substOptions[] = { + "-backslashes", "-commands", "-variables", "-nobackslashes", "-nocommands", "-novariables", NULL }; static const int optionFlags[] = { - TCL_SUBST_BACKSLASHES, TCL_SUBST_COMMANDS, TCL_SUBST_VARIABLES + TCL_SUBST_BACKSLASHES, /* -backslashes */ + TCL_SUBST_COMMANDS, /* -commands */ + TCL_SUBST_VARIABLES, /* -variables */ + TCL_SUBST_BACKSLASHES << 16, /* -nobackslashes */ + TCL_SUBST_COMMANDS << 16, /* -nocommands */ + TCL_SUBST_VARIABLES << 16 /* -novariables */ }; - int flags = TCL_SUBST_ALL; + int flags = numOpts ? 0 : TCL_SUBST_ALL; for (Tcl_Size i = 0; i < numOpts; i++) { int optionIndex; @@ -3359,7 +3366,18 @@ TclSubstOptions( &optionIndex) != TCL_OK) { return TCL_ERROR; } - flags &= ~optionFlags[optionIndex]; + flags |= optionFlags[optionIndex]; + } + if (flags >> 16) { /* negative options specified */ + if (flags & 0xFFFF) { /* positive options specified too */ + if (interp) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "cannot combine positive and negative options", -1)); + } + return TCL_ERROR; + } + /* mask default flags using negative options */ + flags = TCL_SUBST_ALL & ~(flags >> 16); } *flagPtr = flags; return TCL_OK; @@ -3386,6 +3404,7 @@ TclNRSubstObjCmd( if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, + "?-backslashes? ?-commands? ?-variables? " "?-nobackslashes? ?-nocommands? ?-novariables? string"); return TCL_ERROR; } @@ -3848,7 +3867,7 @@ TclNRSwitchObjCmd( if (ctxPtr->type == TCL_LOCATION_SOURCE && ctxPtr->line[bidx] >= 0) { int bline = ctxPtr->line[bidx]; - ctxPtr->line = (Tcl_Size *)Tcl_Alloc(objc * sizeof(Tcl_Size)); + ctxPtr->line = (int *)Tcl_Alloc(objc * sizeof(int)); ctxPtr->nline = objc; TclListLines(blist, bline, objc, ctxPtr->line, objv); } else { @@ -3862,7 +3881,7 @@ TclNRSwitchObjCmd( int k; - ctxPtr->line = (Tcl_Size *)Tcl_Alloc(objc * sizeof(Tcl_Size)); + ctxPtr->line = (int *)Tcl_Alloc(objc * sizeof(int)); ctxPtr->nline = objc; for (k=0; k < objc; k++) { ctxPtr->line[k] = -1; @@ -4281,7 +4300,7 @@ Tcl_TimeRateObjCmd( maxms = -1000; do { lastMeasureOverhead = measureOverhead; - TclNewIntObj(clobjv[i], (int) maxms); + TclNewIntObj(clobjv[i], maxms); Tcl_IncrRefCount(clobjv[i]); result = Tcl_TimeRateObjCmd(NULL, interp, i + 1, clobjv); Tcl_DecrRefCount(clobjv[i]); @@ -4518,10 +4537,10 @@ Tcl_TimeRateObjCmd( * considering last known iteration growth factor. */ threshold = (Tcl_WideUInt)(stop - middle) * TR_SCALE; - /* - * Estimated count of iteration til the end of execution. - * Thereby 2.5% longer execution time would be OK. - */ + /* + * Estimated count of iteration til the end of execution. + * Thereby 2.5% longer execution time would be OK. + */ if (threshold / estIterTm < 0.975) { /* estimated time for next iteration is too large */ break; @@ -5350,10 +5369,10 @@ TclListLines( Tcl_Obj *listObj, /* Pointer to obj holding a string with list * structure. Assumed to be valid. Assumed to * contain n elements. */ - Tcl_Size line, /* Line the list as a whole starts on. */ + int line, /* Line the list as a whole starts on. */ Tcl_Size n, /* #elements in lines */ - Tcl_Size *lines, /* Array of line numbers, to fill. */ - Tcl_Obj *const *elems) /* The list elems as Tcl_Obj*, in need of + int *lines, /* Array of line numbers, to fill. */ + Tcl_Obj *const *elems) /* The list elems as Tcl_Obj*, in need of * derived continuation data */ { const char *listStr = TclGetString(listObj); diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 6c66278..cf074c5 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -37,6 +37,12 @@ static int CompileEachloopCmd(Tcl_Interp *interp, static int CompileDictEachCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr, int collect); +static inline void IssueDictWithEmpty(Tcl_Interp *interp, + Tcl_Size numWords, Tcl_Token *varTokenPtr, + CompileEnv *envPtr); +static inline void IssueDictWithBodied(Tcl_Interp *interp, + Tcl_Size numWords, Tcl_Token *varTokenPtr, + CompileEnv *envPtr); /* * The structures below define the AuxData types defined in this file. @@ -95,6 +101,8 @@ TclGetAuxDataType( return &dictUpdateInfoType; } else if (!strcmp(typeName, tclJumptableInfoType.name)) { return &tclJumptableInfoType; + } else if (!strcmp(typeName, tclJumptableNumericInfoType.name)) { + return &tclJumptableNumericInfoType; } return NULL; } @@ -128,11 +136,12 @@ TclCompileAppendCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr, *valueTokenPtr; - int isScalar, localIndex, numWords, i; + int isScalar; + Tcl_LVTIndex localIndex; + Tcl_Size i, numWords = parsePtr->numWords; /* TODO: Consider support for compiling expanded args. */ - numWords = parsePtr->numWords; - if (numWords == 1) { + if (numWords == 1 || numWords > UINT_MAX) { return TCL_ERROR; } else if (numWords == 2) { /* @@ -158,9 +167,7 @@ TclCompileAppendCmd( */ varTokenPtr = TokenAfter(parsePtr->tokenPtr); - - PushVarNameWord(interp, varTokenPtr, envPtr, 0, - &localIndex, &isScalar, 1); + PushVarNameWord(varTokenPtr, 0, &localIndex, &isScalar, 1); /* * We are doing an assignment, otherwise TclCompileSetCmd was called, so @@ -168,26 +175,26 @@ TclCompileAppendCmd( * each argument. */ - valueTokenPtr = TokenAfter(varTokenPtr); - CompileWord(envPtr, valueTokenPtr, interp, 2); + valueTokenPtr = TokenAfter(varTokenPtr); + PUSH_TOKEN( valueTokenPtr, 2); /* * Emit instructions to set/get the variable. */ - if (isScalar) { - if (localIndex < 0) { - TclEmitOpcode(INST_APPEND_STK, envPtr); - } else { - Emit14Inst(INST_APPEND_SCALAR, localIndex, envPtr); - } + if (isScalar) { + if (localIndex < 0) { + OP( APPEND_STK); } else { - if (localIndex < 0) { - TclEmitOpcode(INST_APPEND_ARRAY_STK, envPtr); - } else { - Emit14Inst(INST_APPEND_ARRAY, localIndex, envPtr); - } + OP4( APPEND_SCALAR, localIndex); + } + } else { + if (localIndex < 0) { + OP( APPEND_ARRAY_STK); + } else { + OP4( APPEND_ARRAY, localIndex); } + } return TCL_OK; @@ -211,14 +218,14 @@ TclCompileAppendCmd( valueTokenPtr = TokenAfter(varTokenPtr); for (i = 2 ; i < numWords ; i++) { - CompileWord(envPtr, valueTokenPtr, interp, i); + PUSH_TOKEN( valueTokenPtr, i); valueTokenPtr = TokenAfter(valueTokenPtr); } - TclEmitInstInt4( INST_REVERSE, numWords-2, envPtr); + OP4( REVERSE, numWords - 2); for (i = 2 ; i < numWords ;) { - Emit14Inst( INST_APPEND_SCALAR, localIndex, envPtr); + OP4( APPEND_SCALAR, localIndex); if (++i < numWords) { - TclEmitOpcode(INST_POP, envPtr); + OP( POP); } } @@ -253,23 +260,23 @@ TclCompileArrayExistsCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - int isScalar, localIndex; + int isScalar; + Tcl_LVTIndex localIndex; if (parsePtr->numWords != 2) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); - PushVarNameWord(interp, tokenPtr, envPtr, TCL_NO_ELEMENT, - &localIndex, &isScalar, 1); - if (!isScalar) { + PushVarNameWord(tokenPtr, TCL_NO_ELEMENT, &localIndex, &isScalar, 1); + if (!isScalar || localIndex > UINT_MAX) { return TCL_ERROR; } if (localIndex >= 0) { - TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr); + OP4( ARRAY_EXISTS_IMM, localIndex); } else { - TclEmitOpcode( INST_ARRAY_EXISTS_STK, envPtr); + OP( ARRAY_EXISTS_STK); } return TCL_OK; } @@ -285,13 +292,13 @@ TclCompileArraySetCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr, *dataTokenPtr; - int isScalar, localIndex, code = TCL_OK; - int isDataLiteral, isDataValid, isDataEven; + int isScalar, code = TCL_OK, isDataLiteral, isDataValid, isDataEven; Tcl_Size len; - int keyVar, valVar, infoIndex; - int fwd, offsetBack, offsetFwd; + Tcl_LVTIndex keyVar, valVar, localIndex; + Tcl_AuxDataRef infoIndex; Tcl_Obj *literalObj; ForeachInfo *infoPtr; + Tcl_BytecodeLabel arrayMade, offsetBack; if (parsePtr->numWords != 3) { return TCL_ERROR; @@ -319,10 +326,9 @@ TclCompileArraySetCmd( * but that was wrong because it would not invoke the array trace * on the variable. * - PushStringLiteral(envPtr, "list must have an even number of elements"); - PushStringLiteral(envPtr, "-errorcode {TCL ARGUMENT FORMAT}"); - TclEmitInstInt4(INST_RETURN_IMM, TCL_ERROR, envPtr); - TclEmitInt4( 0, envPtr); + PUSH( "list must have an even number of elements"); + PUSH( "-errorcode {TCL ARGUMENT FORMAT}"); + OP44( RETURN_IMM, TCL_ERROR, 0); goto done; * */ @@ -334,14 +340,13 @@ TclCompileArraySetCmd( */ if ((varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) || - (envPtr->procPtr == NULL && !(isDataEven && len == 0))) { + (!EnvIsProc(envPtr) && !(isDataEven && len == 0))) { code = TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr); goto done; } - PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_ELEMENT, - &localIndex, &isScalar, 1); - if (!isScalar) { + PushVarNameWord(varTokenPtr, TCL_NO_ELEMENT, &localIndex, &isScalar, 1); + if (!isScalar || localIndex > UINT_MAX) { code = TCL_ERROR; goto done; } @@ -353,20 +358,26 @@ TclCompileArraySetCmd( if (isDataEven && len == 0) { if (localIndex >= 0) { - TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr); - TclEmitInstInt1(INST_JUMP_TRUE1, 7, envPtr); - TclEmitInstInt4(INST_ARRAY_MAKE_IMM, localIndex, envPtr); + Tcl_BytecodeLabel haveArray; + OP4( ARRAY_EXISTS_IMM, localIndex); + FWDJUMP( JUMP_TRUE, haveArray); + OP4( ARRAY_MAKE_IMM, localIndex); + FWDLABEL( haveArray); } else { - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_ARRAY_EXISTS_STK, envPtr); - TclEmitInstInt1(INST_JUMP_TRUE1, 5, envPtr); - TclEmitOpcode( INST_ARRAY_MAKE_STK, envPtr); - TclEmitInstInt1(INST_JUMP1, 3, envPtr); + Tcl_BytecodeLabel haveArray; + OP( DUP); + OP( ARRAY_EXISTS_STK); + FWDJUMP( JUMP_TRUE, haveArray); + OP( ARRAY_MAKE_STK); + FWDJUMP( JUMP, arrayMade); + /* Each branch decrements stack depth, but we only take one. */ - TclAdjustStackDepth(1, envPtr); - TclEmitOpcode( INST_POP, envPtr); + STKDELTA(+1); + FWDLABEL( haveArray); + OP( POP); + FWDLABEL( arrayMade); } - PushStringLiteral(envPtr, ""); + PUSH( ""); goto done; } @@ -378,10 +389,10 @@ TclCompileArraySetCmd( localIndex = TclFindCompiledLocal(varTokenPtr->start, varTokenPtr->size, 1, envPtr); - PushStringLiteral(envPtr, "0"); - TclEmitInstInt4(INST_REVERSE, 2, envPtr); - TclEmitInstInt4(INST_UPVAR, localIndex, envPtr); - TclEmitOpcode(INST_POP, envPtr); + PUSH( "0"); + OP( SWAP); + OP4( UPVAR, localIndex); + OP( POP); } /* @@ -391,9 +402,11 @@ TclCompileArraySetCmd( keyVar = AnonymousLocal(envPtr); valVar = AnonymousLocal(envPtr); - infoPtr = (ForeachInfo *)Tcl_Alloc(offsetof(ForeachInfo, varLists) + sizeof(ForeachVarList *)); + infoPtr = (ForeachInfo *)Tcl_Alloc( + offsetof(ForeachInfo, varLists) + sizeof(ForeachVarList *)); infoPtr->numLists = 1; - infoPtr->varLists[0] = (ForeachVarList *)Tcl_Alloc(offsetof(ForeachVarList, varIndexes) + 2 * sizeof(Tcl_Size)); + infoPtr->varLists[0] = (ForeachVarList *)Tcl_Alloc( + offsetof(ForeachVarList, varIndexes) + 2 * sizeof(Tcl_Size)); infoPtr->varLists[0]->numVars = 2; infoPtr->varLists[0]->varIndexes[0] = keyVar; infoPtr->varLists[0]->varIndexes[1] = valVar; @@ -403,11 +416,12 @@ TclCompileArraySetCmd( * Start issuing instructions to write to the array. */ - TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr); - TclEmitInstInt1(INST_JUMP_TRUE1, 7, envPtr); - TclEmitInstInt4(INST_ARRAY_MAKE_IMM, localIndex, envPtr); + OP4( ARRAY_EXISTS_IMM, localIndex); + FWDJUMP( JUMP_TRUE, arrayMade); + OP4( ARRAY_MAKE_IMM, localIndex); + FWDLABEL( arrayMade); - CompileWord(envPtr, dataTokenPtr, interp, 2); + PUSH_TOKEN( dataTokenPtr, 2); if (!isDataLiteral || !isDataValid) { /* * Only need this safety check if we're handling a non-literal or list @@ -416,34 +430,32 @@ TclCompileArraySetCmd( * use-case with [array set]). */ - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_LIST_LENGTH, envPtr); - PushStringLiteral(envPtr, "1"); - TclEmitOpcode( INST_BITAND, envPtr); - offsetFwd = CurrentOffset(envPtr); - TclEmitInstInt1(INST_JUMP_FALSE1, 0, envPtr); - PushStringLiteral(envPtr, "list must have an even number of elements"); - PushStringLiteral(envPtr, "-errorcode {TCL ARGUMENT FORMAT}"); - TclEmitInstInt4(INST_RETURN_IMM, TCL_ERROR, envPtr); - TclEmitInt4( 0, envPtr); - TclAdjustStackDepth(-1, envPtr); - fwd = CurrentOffset(envPtr) - offsetFwd; - TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1); - } - - TclEmitInstInt4(INST_FOREACH_START, infoIndex, envPtr); - offsetBack = CurrentOffset(envPtr); - Emit14Inst( INST_LOAD_SCALAR, keyVar, envPtr); - Emit14Inst( INST_LOAD_SCALAR, valVar, envPtr); - Emit14Inst( INST_STORE_ARRAY, localIndex, envPtr); - TclEmitOpcode( INST_POP, envPtr); + Tcl_BytecodeLabel ok; + OP( DUP); + OP( LIST_LENGTH); + PUSH( "1"); + OP( BITAND); + FWDJUMP( JUMP_FALSE, ok); + PUSH( "list must have an even number of elements"); + PUSH( "-errorcode {TCL ARGUMENT FORMAT}"); + OP44( RETURN_IMM, TCL_ERROR, 0); + STKDELTA(-1); + FWDLABEL( ok); + } + + OP4( FOREACH_START, infoIndex); + BACKLABEL( offsetBack); + OP4( LOAD_SCALAR, keyVar); + OP4( LOAD_SCALAR, valVar); + OP4( STORE_ARRAY, localIndex); + OP( POP); infoPtr->loopCtTemp = offsetBack - CurrentOffset(envPtr); /*misuse */ - TclEmitOpcode( INST_FOREACH_STEP, envPtr); - TclEmitOpcode( INST_FOREACH_END, envPtr); - TclAdjustStackDepth(-3, envPtr); - PushStringLiteral(envPtr, ""); + OP( FOREACH_STEP); + OP( FOREACH_END); + STKDELTA(-3); + PUSH( ""); - done: + done: Tcl_DecrRefCount(literalObj); return code; } @@ -459,34 +471,37 @@ TclCompileArrayUnsetCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); - int isScalar, localIndex; + int isScalar; + Tcl_LVTIndex localIndex; + Tcl_BytecodeLabel noSuchArray, end; if (parsePtr->numWords != 2) { return TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr); } - PushVarNameWord(interp, tokenPtr, envPtr, TCL_NO_ELEMENT, - &localIndex, &isScalar, 1); + PushVarNameWord(tokenPtr, TCL_NO_ELEMENT, &localIndex, &isScalar, 1); if (!isScalar) { return TCL_ERROR; } if (localIndex >= 0) { - TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr); - TclEmitInstInt1(INST_JUMP_FALSE1, 8, envPtr); - TclEmitInstInt1(INST_UNSET_SCALAR, 1, envPtr); - TclEmitInt4( localIndex, envPtr); + OP4( ARRAY_EXISTS_IMM, localIndex); + FWDJUMP( JUMP_FALSE, end); + OP14( UNSET_SCALAR, 1, localIndex); } else { - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_ARRAY_EXISTS_STK, envPtr); - TclEmitInstInt1(INST_JUMP_FALSE1, 6, envPtr); - TclEmitInstInt1(INST_UNSET_STK, 1, envPtr); - TclEmitInstInt1(INST_JUMP1, 3, envPtr); + OP( DUP); + OP( ARRAY_EXISTS_STK); + FWDJUMP( JUMP_FALSE, noSuchArray); + OP1( UNSET_STK, 1); + FWDJUMP( JUMP, end); + /* Each branch decrements stack depth, but we only take one. */ - TclAdjustStackDepth(1, envPtr); - TclEmitOpcode( INST_POP, envPtr); + STKDELTA(+1); + FWDLABEL( noSuchArray); + OP( POP); } - PushStringLiteral(envPtr, ""); + FWDLABEL( end); + PUSH( ""); return TCL_OK; } @@ -540,9 +555,9 @@ TclCompileBreakCmd( * Emit a real break. */ - TclEmitOpcode(INST_BREAK, envPtr); + OP( BREAK); } - TclAdjustStackDepth(1, envPtr); + STKDELTA(+1); return TCL_OK; } @@ -574,17 +589,19 @@ TclCompileCatchCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ - JumpFixup jumpFixup; Tcl_Token *cmdTokenPtr, *resultNameTokenPtr, *optsNameTokenPtr; - int resultIndex, optsIndex, range, dropScript = 0; - int depth = TclGetStackDepth(envPtr); + int dropScript = 0; + Tcl_LVTIndex resultIndex, optsIndex; + Tcl_BytecodeLabel haveResultAndCode; + Tcl_ExceptionRange range; + Tcl_Size depth = TclGetStackDepth(envPtr), numWords = parsePtr->numWords; /* * If syntax does not match what we expect for [catch], do not compile. * Let runtime checks determine if syntax has changed. */ - if (((int)parsePtr->numWords < 2) || ((int)parsePtr->numWords > 4)) { + if ((numWords < 2) || (numWords > 4)) { return TCL_ERROR; } @@ -593,7 +610,7 @@ TclCompileCatchCmd( * (not in a procedure), don't compile it inline: the payoff is too small. */ - if (((int)parsePtr->numWords >= 3) && !EnvHasLVT(envPtr)) { + if ((numWords >= 3) && !EnvHasLVT(envPtr)) { return TCL_ERROR; } @@ -602,9 +619,9 @@ TclCompileCatchCmd( * refer to local scalars. */ - resultIndex = optsIndex = -1; + resultIndex = optsIndex = TCL_INDEX_NONE; cmdTokenPtr = TokenAfter(parsePtr->tokenPtr); - if ((int)parsePtr->numWords >= 3) { + if (numWords >= 3) { resultNameTokenPtr = TokenAfter(cmdTokenPtr); /* DGP */ resultIndex = LocalScalarFromToken(resultNameTokenPtr, envPtr); @@ -613,7 +630,7 @@ TclCompileCatchCmd( } /* DKF */ - if (parsePtr->numWords == 4) { + if (numWords == 4) { optsNameTokenPtr = TokenAfter(resultNameTokenPtr); optsIndex = LocalScalarFromToken(optsNameTokenPtr, envPtr); if (optsIndex < 0) { @@ -638,24 +655,24 @@ TclCompileCatchCmd( * begin by underflowing the stack below the mark set by BEGIN_CATCH4. */ - range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); + range = MAKE_CATCH_RANGE(); if (cmdTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); - ExceptionRangeStarts(envPtr, range); - BODY(cmdTokenPtr, 1); + OP4( BEGIN_CATCH, range); + CATCH_RANGE(range) { + BODY( cmdTokenPtr, 1); + } } else { - SetLineInformation(1); - CompileTokens(envPtr, cmdTokenPtr, interp); - TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); - ExceptionRangeStarts(envPtr, range); - TclEmitOpcode( INST_DUP, envPtr); - TclEmitInvoke(envPtr, INST_EVAL_STK); + PUSH_TOKEN( cmdTokenPtr, 1); + OP4( BEGIN_CATCH, range); + OP( DUP); + CATCH_RANGE(range) { + INVOKE( EVAL_STK); + } /* drop the script */ dropScript = 1; - TclEmitInstInt4( INST_REVERSE, 2, envPtr); - TclEmitOpcode( INST_POP, envPtr); + OP( SWAP); + OP( POP); } - ExceptionRangeEnds(envPtr, range); /* * Emit the "no errors" epilogue: push "0" (TCL_OK) as the catch result, @@ -663,68 +680,58 @@ TclCompileCatchCmd( */ TclCheckStackDepth(depth+1, envPtr); - PushStringLiteral(envPtr, "0"); - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); + PUSH( "0"); + OP( SWAP); + FWDJUMP( JUMP, haveResultAndCode); /* * Emit the "error case" epilogue. Push the interpreter result and the * return code. */ - ExceptionRangeTarget(envPtr, range, catchOffset); + CATCH_TARGET( range); TclSetStackDepth(depth + dropScript, envPtr); if (dropScript) { - TclEmitOpcode( INST_POP, envPtr); + OP( POP); } /* Stack at this point is empty */ - TclEmitOpcode( INST_PUSH_RESULT, envPtr); - TclEmitOpcode( INST_PUSH_RETURN_CODE, envPtr); + OP( PUSH_RETURN_CODE); + OP( PUSH_RESULT); - /* Stack at this point on both branches: result returnCode */ + /* Stack at this point on both branches: returnCode result */ - if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) { - Tcl_Panic("TclCompileCatchCmd: bad jump distance %" TCL_Z_MODIFIER "d", - (CurrentOffset(envPtr) - jumpFixup.codeOffset)); - } + FWDLABEL( haveResultAndCode); /* * Push the return options if the caller wants them. This needs to happen * before INST_END_CATCH */ - if (optsIndex != -1) { - TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); + if (optsIndex != TCL_INDEX_NONE) { + OP( PUSH_RETURN_OPTIONS); } /* * End the catch */ - TclEmitOpcode( INST_END_CATCH, envPtr); + OP( END_CATCH); /* * Save the result and return options if the caller wants them. This needs * to happen after INST_END_CATCH (compile-3.6/7). */ - if (optsIndex != -1) { - Emit14Inst( INST_STORE_SCALAR, optsIndex, envPtr); - TclEmitOpcode( INST_POP, envPtr); + if (optsIndex != TCL_INDEX_NONE) { + OP4( STORE_SCALAR, optsIndex); + OP( POP); } - - /* - * At this point, the top of the stack is inconveniently ordered: - * result returnCode - * Reverse the stack to store the result. - */ - - TclEmitInstInt4( INST_REVERSE, 2, envPtr); - if (resultIndex != -1) { - Emit14Inst( INST_STORE_SCALAR, resultIndex, envPtr); + if (resultIndex != TCL_INDEX_NONE) { + OP4( STORE_SCALAR, resultIndex); } - TclEmitOpcode( INST_POP, envPtr); + OP( POP); TclCheckStackDepth(depth+1, envPtr); return TCL_OK; @@ -762,28 +769,21 @@ TclCompileClockClicksCmd( /* * No args */ - TclEmitInstInt1(INST_CLOCK_READ, 0, envPtr); + OP1( CLOCK_READ, CLOCK_READ_CLICKS); break; case 2: /* * -milliseconds or -microseconds */ tokenPtr = TokenAfter(parsePtr->tokenPtr); - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD - || tokenPtr[1].size < 4 - || tokenPtr[1].size > 13) { - return TCL_ERROR; - } else if (!strncmp(tokenPtr[1].start, "-microseconds", - tokenPtr[1].size)) { - TclEmitInstInt1(INST_CLOCK_READ, 1, envPtr); - break; - } else if (!strncmp(tokenPtr[1].start, "-milliseconds", - tokenPtr[1].size)) { - TclEmitInstInt1(INST_CLOCK_READ, 2, envPtr); - break; + if (IS_TOKEN_PREFIX(tokenPtr, 3, "-microseconds")) { + OP1( CLOCK_READ, CLOCK_READ_MICROS); + } else if (IS_TOKEN_PREFIX(tokenPtr, 3, "-milliseconds")) { + OP1( CLOCK_READ, CLOCK_READ_MILLIS); } else { return TCL_ERROR; } + break; default: return TCL_ERROR; } @@ -822,8 +822,7 @@ TclCompileClockReadingCmd( return TCL_ERROR; } - TclEmitInstInt1(INST_CLOCK_READ, PTR2INT(cmdPtr->objClientData), envPtr); - + OP1( CLOCK_READ, PTR2INT(cmdPtr->objClientData)); return TCL_OK; } @@ -854,62 +853,54 @@ TclCompileConcatCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ - Tcl_Obj *objPtr, *listObj; + Tcl_Obj *objPtr, *listObj, **objs; + Tcl_Size len, i, numWords = parsePtr->numWords; Tcl_Token *tokenPtr; - int i; /* TODO: Consider compiling expansion case. */ - if (parsePtr->numWords == 1) { + if (numWords == 1) { /* * [concat] without arguments just pushes an empty object. */ - PushStringLiteral(envPtr, ""); + PUSH( ""); return TCL_OK; + } else if (numWords > UINT_MAX) { + return TCL_ERROR; } /* * Test if all arguments are compile-time known. If they are, we can - * implement with a simple push. + * implement with a simple push of a literal. */ TclNewObj(listObj); - for (i = 1, tokenPtr = parsePtr->tokenPtr; i < (int)parsePtr->numWords; i++) { + for (i = 1, tokenPtr = parsePtr->tokenPtr; i < numWords; i++) { tokenPtr = TokenAfter(tokenPtr); TclNewObj(objPtr); if (!TclWordKnownAtCompileTime(tokenPtr, objPtr)) { - Tcl_DecrRefCount(objPtr); - Tcl_DecrRefCount(listObj); - listObj = NULL; - break; + Tcl_BounceRefCount(objPtr); + Tcl_BounceRefCount(listObj); + goto runtimeConcat; } (void) Tcl_ListObjAppendElement(NULL, listObj, objPtr); } - if (listObj != NULL) { - Tcl_Obj **objs; - const char *bytes; - Tcl_Size len, slen; - - TclListObjGetElements(NULL, listObj, &len, &objs); - objPtr = Tcl_ConcatObj(len, objs); - Tcl_DecrRefCount(listObj); - bytes = TclGetStringFromObj(objPtr, &slen); - PushLiteral(envPtr, bytes, slen); - Tcl_DecrRefCount(objPtr); - return TCL_OK; - } + + TclListObjGetElements(NULL, listObj, &len, &objs); + PUSH_OBJ( Tcl_ConcatObj(len, objs)); + Tcl_BounceRefCount(listObj); + return TCL_OK; /* - * General case: runtime concat. + * General case: do the concatenation at runtime. */ - for (i = 1, tokenPtr = parsePtr->tokenPtr; i < (int)parsePtr->numWords; i++) { + runtimeConcat: + for (i = 1, tokenPtr = parsePtr->tokenPtr; i < numWords; i++) { tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, i); + PUSH_TOKEN( tokenPtr, i); } - - TclEmitInstInt4( INST_CONCAT_STK, i-1, envPtr); - + OP4( CONCAT_STK, i - 1); return TCL_OK; } @@ -941,7 +932,8 @@ TclCompileConstCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr, *valueTokenPtr; - int isScalar, localIndex; + int isScalar; + Tcl_LVTIndex localIndex; /* * Need exactly two arguments. @@ -959,14 +951,13 @@ TclCompileConstCmd( */ varTokenPtr = TokenAfter(parsePtr->tokenPtr); - PushVarNameWord(interp, varTokenPtr, envPtr, 0, - &localIndex, &isScalar, 1); + PushVarNameWord(varTokenPtr, 0, &localIndex, &isScalar, 1); /* * If the user specified an array element, we don't bother handling * that. */ - if (!isScalar) { + if (!isScalar || localIndex > UINT_MAX) { return TCL_ERROR; } @@ -976,18 +967,18 @@ TclCompileConstCmd( */ valueTokenPtr = TokenAfter(varTokenPtr); - CompileWord(envPtr, valueTokenPtr, interp, 2); + PUSH_TOKEN( valueTokenPtr, 2); if (localIndex < 0) { - TclEmitOpcode(INST_CONST_STK, envPtr); + OP( CONST_STK); } else { - TclEmitInstInt4(INST_CONST_IMM, localIndex, envPtr); + OP4( CONST_IMM, localIndex); } /* * The const command's result is an empty string. */ - PushStringLiteral(envPtr, ""); + PUSH( ""); return TCL_OK; } @@ -1046,9 +1037,9 @@ TclCompileContinueCmd( * Emit a real continue. */ - TclEmitOpcode(INST_CONTINUE, envPtr); + OP( CONTINUE); } - TclAdjustStackDepth(1, envPtr); + STKDELTA(+1); return TCL_OK; } @@ -1081,14 +1072,16 @@ TclCompileDictSetCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - int i, dictVarIndex; + Tcl_Size i, numWords = parsePtr->numWords; + Tcl_LVTIndex dictVarIndex; Tcl_Token *varTokenPtr; + /* TODO: Consider support for compiling expanded args. */ /* * There must be at least one argument after the command. */ - if ((int)parsePtr->numWords < 4) { + if (numWords < 4 || numWords > UINT_MAX) { return TCL_ERROR; } @@ -1109,8 +1102,8 @@ TclCompileDictSetCmd( */ tokenPtr = TokenAfter(varTokenPtr); - for (i=2 ; i< (int)parsePtr->numWords ; i++) { - CompileWord(envPtr, tokenPtr, interp, i); + for (i=2 ; i<numWords ; i++) { + PUSH_TOKEN( tokenPtr, i); tokenPtr = TokenAfter(tokenPtr); } @@ -1118,9 +1111,7 @@ TclCompileDictSetCmd( * Now emit the instruction to do the dict manipulation. */ - TclEmitInstInt4( INST_DICT_SET, (int)parsePtr->numWords-3, envPtr); - TclEmitInt4( dictVarIndex, envPtr); - TclAdjustStackDepth(-1, envPtr); + OP44( DICT_SET, numWords - 3, dictVarIndex); return TCL_OK; } @@ -1135,13 +1126,14 @@ TclCompileDictIncrCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr, *keyTokenPtr; - int dictVarIndex, incrAmount; + Tcl_LVTIndex dictVarIndex; + int incrAmount; /* * There must be at least two arguments after the command. */ - if ((int)parsePtr->numWords < 3 || (int)parsePtr->numWords > 4) { + if (parsePtr->numWords < 3 || parsePtr->numWords > 4) { return TCL_ERROR; } varTokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -1152,23 +1144,17 @@ TclCompileDictIncrCmd( */ if (parsePtr->numWords == 4) { - const char *word; - Tcl_Size numBytes; - int code; - Tcl_Token *incrTokenPtr; + Tcl_Token *incrTokenPtr = TokenAfter(keyTokenPtr); Tcl_Obj *intObj; + int code; - incrTokenPtr = TokenAfter(keyTokenPtr); - if (incrTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + TclNewObj(intObj); + if (!TclWordKnownAtCompileTime(incrTokenPtr, intObj)) { + Tcl_BounceRefCount(intObj); return TclCompileBasic2Or3ArgCmd(interp, parsePtr,cmdPtr, envPtr); } - word = incrTokenPtr[1].start; - numBytes = incrTokenPtr[1].size; - - intObj = Tcl_NewStringObj(word, numBytes); - Tcl_IncrRefCount(intObj); code = TclGetIntFromObj(NULL, intObj, &incrAmount); - TclDecrRefCount(intObj); + Tcl_BounceRefCount(intObj); if (code != TCL_OK) { return TclCompileBasic2Or3ArgCmd(interp, parsePtr,cmdPtr, envPtr); } @@ -1191,9 +1177,8 @@ TclCompileDictIncrCmd( * Emit the key and the code to actually do the increment. */ - CompileWord(envPtr, keyTokenPtr, interp, 2); - TclEmitInstInt4( INST_DICT_INCR_IMM, incrAmount, envPtr); - TclEmitInt4( dictVarIndex, envPtr); + PUSH_TOKEN( keyTokenPtr, 2); + OP44( DICT_INCR_IMM, incrAmount, dictVarIndex); return TCL_OK; } @@ -1207,7 +1192,7 @@ TclCompileDictGetCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - int i; + Tcl_Size i, numWords = parsePtr->numWords; /* * There must be at least two arguments after the command (the single-arg @@ -1215,7 +1200,7 @@ TclCompileDictGetCmd( */ /* TODO: Consider support for compiling expanded args. */ - if ((int)parsePtr->numWords < 3) { + if (numWords < 3 || numWords > UINT_MAX) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -1224,12 +1209,11 @@ TclCompileDictGetCmd( * Only compile this because we need INST_DICT_GET anyway. */ - for (i=1 ; i<(int)parsePtr->numWords ; i++) { - CompileWord(envPtr, tokenPtr, interp, i); + for (i=1 ; i<numWords ; i++) { + PUSH_TOKEN( tokenPtr, i); tokenPtr = TokenAfter(tokenPtr); } - TclEmitInstInt4(INST_DICT_GET, (int)parsePtr->numWords-2, envPtr); - TclAdjustStackDepth(-1, envPtr); + OP4( DICT_GET, numWords - 2); return TCL_OK; } @@ -1243,24 +1227,23 @@ TclCompileDictGetWithDefaultCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - int i; + Tcl_Size i, numWords = parsePtr->numWords; /* * There must be at least three arguments after the command. */ /* TODO: Consider support for compiling expanded args. */ - if ((int)parsePtr->numWords < 4) { + if (numWords < 4 || numWords > UINT_MAX) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); - for (i=1 ; i<(int)parsePtr->numWords ; i++) { - CompileWord(envPtr, tokenPtr, interp, i); + for (i=1 ; i<numWords ; i++) { + PUSH_TOKEN( tokenPtr, i); tokenPtr = TokenAfter(tokenPtr); } - TclEmitInstInt4(INST_DICT_GET_DEF, (int)parsePtr->numWords-3, envPtr); - TclAdjustStackDepth(-2, envPtr); + OP4( DICT_GET_DEF, numWords - 3); return TCL_OK; } @@ -1274,7 +1257,7 @@ TclCompileDictExistsCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - int i; + Tcl_Size i, numWords = parsePtr->numWords; /* * There must be at least two arguments after the command (the single-arg @@ -1282,7 +1265,7 @@ TclCompileDictExistsCmd( */ /* TODO: Consider support for compiling expanded args. */ - if ((int)parsePtr->numWords < 3) { + if (numWords < 3 || numWords > UINT_MAX) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -1291,12 +1274,84 @@ TclCompileDictExistsCmd( * Now we do the code generation. */ - for (i=1 ; i<(int)parsePtr->numWords ; i++) { - CompileWord(envPtr, tokenPtr, interp, i); + for (i=1 ; i<numWords ; i++) { + PUSH_TOKEN( tokenPtr, i); tokenPtr = TokenAfter(tokenPtr); } - TclEmitInstInt4(INST_DICT_EXISTS, (int)parsePtr->numWords-2, envPtr); - TclAdjustStackDepth(-1, envPtr); + OP4( DICT_EXISTS, numWords - 2); + return TCL_OK; +} + +int +TclCompileDictReplaceCmd( + Tcl_Interp *interp, /* Used for looking up stuff. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + TCL_UNUSED(Command *), + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Size i, numWords = parsePtr->numWords; + Tcl_Token *tokenPtr; + /* TODO: Consider support for compiling expanded args. */ + + /* + * Don't compile [dict replace $dict]; it's an edge case. + */ + if (numWords <= 3 || numWords > UINT_MAX || (numWords % 1)) { + return TCL_ERROR; + } + + // Push starting dictionary + tokenPtr = TokenAfter(parsePtr->tokenPtr); + PUSH_TOKEN( tokenPtr, 1); + + // Push the keys and values, and add them to the dictionary + for (i=2; i<numWords; i+=2) { + // Push key + tokenPtr = TokenAfter(tokenPtr); + PUSH_TOKEN( tokenPtr, i); + // Push value + tokenPtr = TokenAfter(tokenPtr); + PUSH_TOKEN( tokenPtr, i + 1); + OP( DICT_PUT); + } + + return TCL_OK; +} + +int +TclCompileDictRemoveCmd( + Tcl_Interp *interp, /* Used for looking up stuff. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + TCL_UNUSED(Command *), + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Size i, numWords = parsePtr->numWords; + Tcl_Token *tokenPtr; + /* TODO: Consider support for compiling expanded args. */ + + /* + * Don't compile [dict remove $dict]; it's an edge case. + */ + if (numWords <= 2 || numWords > UINT_MAX) { + return TCL_ERROR; + } + + // Push starting dictionary + tokenPtr = TokenAfter(parsePtr->tokenPtr); + PUSH_TOKEN( tokenPtr, 1); + + // Push the keys, and remove them from the dictionary + for (i=2; i<numWords; i++) { + // Push key + tokenPtr = TokenAfter(tokenPtr); + PUSH_TOKEN( tokenPtr, i); + OP( DICT_REMOVE); + } + return TCL_OK; } @@ -1311,7 +1366,8 @@ TclCompileDictUnsetCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - int i, dictVarIndex; + Tcl_Size i, numWords = parsePtr->numWords; + Tcl_LVTIndex dictVarIndex; /* * There must be at least one argument after the variable name for us to @@ -1319,7 +1375,7 @@ TclCompileDictUnsetCmd( */ /* TODO: Consider support for compiling expanded args. */ - if ((int)parsePtr->numWords < 3) { + if (numWords < 3 || numWords > UINT_MAX) { return TCL_ERROR; } @@ -1339,17 +1395,16 @@ TclCompileDictUnsetCmd( * Remaining words (the key path) can be handled normally. */ - for (i=2 ; i<(int)parsePtr->numWords ; i++) { + for (i=2 ; i<numWords ; i++) { tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, i); + PUSH_TOKEN( tokenPtr, i); } /* * Now emit the instruction to do the dict manipulation. */ - TclEmitInstInt4( INST_DICT_UNSET, (int)parsePtr->numWords-2, envPtr); - TclEmitInt4( dictVarIndex, envPtr); + OP44( DICT_UNSET, numWords - 2, dictVarIndex); return TCL_OK; } @@ -1358,19 +1413,16 @@ TclCompileDictCreateCmd( Tcl_Interp *interp, /* Used for looking up stuff. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to definition of command being - * compiled. */ + TCL_UNUSED(Command *), CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ - int worker; /* Temp var for building the value in. */ - Tcl_Token *tokenPtr; + Tcl_Token *keyToken, *valueToken; Tcl_Obj *keyObj, *valueObj, *dictObj; - const char *bytes; - int i; - Tcl_Size len; + Tcl_Size i, numWords = parsePtr->numWords; + /* TODO: Consider support for compiling expanded args. */ - if ((parsePtr->numWords & 1) == 0) { + if ((numWords & 1) == 0 || numWords > UINT_MAX) { return TCL_ERROR; } @@ -1378,41 +1430,35 @@ TclCompileDictCreateCmd( * See if we can build the value at compile time... */ - tokenPtr = TokenAfter(parsePtr->tokenPtr); + keyToken = TokenAfter(parsePtr->tokenPtr); TclNewObj(dictObj); - Tcl_IncrRefCount(dictObj); - for (i=1 ; i<(int)parsePtr->numWords ; i+=2) { + for (i=1 ; i<numWords ; i+=2) { TclNewObj(keyObj); - Tcl_IncrRefCount(keyObj); - if (!TclWordKnownAtCompileTime(tokenPtr, keyObj)) { - Tcl_DecrRefCount(keyObj); - Tcl_DecrRefCount(dictObj); + if (!TclWordKnownAtCompileTime(keyToken, keyObj)) { + Tcl_BounceRefCount(keyObj); + Tcl_BounceRefCount(dictObj); goto nonConstant; } - tokenPtr = TokenAfter(tokenPtr); + valueToken = TokenAfter(keyToken); TclNewObj(valueObj); - Tcl_IncrRefCount(valueObj); - if (!TclWordKnownAtCompileTime(tokenPtr, valueObj)) { - Tcl_DecrRefCount(keyObj); - Tcl_DecrRefCount(valueObj); - Tcl_DecrRefCount(dictObj); + if (!TclWordKnownAtCompileTime(valueToken, valueObj)) { + Tcl_BounceRefCount(keyObj); + Tcl_BounceRefCount(valueObj); + Tcl_BounceRefCount(dictObj); goto nonConstant; } - tokenPtr = TokenAfter(tokenPtr); + keyToken = TokenAfter(valueToken); Tcl_DictObjPut(NULL, dictObj, keyObj, valueObj); - Tcl_DecrRefCount(keyObj); - Tcl_DecrRefCount(valueObj); + Tcl_BounceRefCount(keyObj); } /* * We did! Excellent. The "verifyDict" is to do type forcing. */ - bytes = TclGetStringFromObj(dictObj, &len); - PushLiteral(envPtr, bytes, len); - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_DICT_VERIFY, envPtr); - Tcl_DecrRefCount(dictObj); + PUSH_OBJ( dictObj); + OP( DUP); + OP( DICT_VERIFY); return TCL_OK; /* @@ -1422,28 +1468,15 @@ TclCompileDictCreateCmd( */ nonConstant: - worker = AnonymousLocal(envPtr); - if (worker < 0) { - return TclCompileBasicMin0ArgCmd(interp, parsePtr, cmdPtr, envPtr); + PUSH( ""); + keyToken = TokenAfter(parsePtr->tokenPtr); + for (i=1 ; i<numWords ; i+=2) { + valueToken = TokenAfter(keyToken); + PUSH_TOKEN( keyToken, i); + PUSH_TOKEN( valueToken, i + 1); + OP( DICT_PUT); + keyToken = TokenAfter(valueToken); } - - PushStringLiteral(envPtr, ""); - Emit14Inst( INST_STORE_SCALAR, worker, envPtr); - TclEmitOpcode( INST_POP, envPtr); - tokenPtr = TokenAfter(parsePtr->tokenPtr); - for (i=1 ; i<(int)parsePtr->numWords ; i+=2) { - CompileWord(envPtr, tokenPtr, interp, i); - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, i+1); - tokenPtr = TokenAfter(tokenPtr); - TclEmitInstInt4( INST_DICT_SET, 1, envPtr); - TclEmitInt4( worker, envPtr); - TclAdjustStackDepth(-1, envPtr); - TclEmitOpcode( INST_POP, envPtr); - } - Emit14Inst( INST_LOAD_SCALAR, worker, envPtr); - TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); - TclEmitInt4( worker, envPtr); return TCL_OK; } @@ -1458,7 +1491,10 @@ TclCompileDictMergeCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - int i, workerIndex, infoIndex, outLoop; + Tcl_Size i, numWords = parsePtr->numWords; + Tcl_LVTIndex infoIndex; + Tcl_ExceptionRange outLoop; + Tcl_BytecodeLabel end; /* * Deal with some special edge cases. Note that in the case with one @@ -1466,14 +1502,14 @@ TclCompileDictMergeCmd( */ /* TODO: Consider support for compiling expanded args. (less likely) */ - if ((int)parsePtr->numWords < 2) { - PushStringLiteral(envPtr, ""); + if (numWords < 2) { + PUSH( ""); return TCL_OK; - } else if (parsePtr->numWords == 2) { + } else if (numWords == 2) { tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_DICT_VERIFY, envPtr); + PUSH_TOKEN( tokenPtr, 1); + OP( DUP); + OP( DICT_VERIFY); return TCL_OK; } @@ -1484,8 +1520,7 @@ TclCompileDictMergeCmd( * command when there's an LVT present. */ - workerIndex = AnonymousLocal(envPtr); - if (workerIndex < 0) { + if (!EnvIsProc(envPtr)) { return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr); } infoIndex = AnonymousLocal(envPtr); @@ -1495,69 +1530,61 @@ TclCompileDictMergeCmd( */ tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_DICT_VERIFY, envPtr); - Emit14Inst( INST_STORE_SCALAR, workerIndex, envPtr); - TclEmitOpcode( INST_POP, envPtr); + PUSH_TOKEN( tokenPtr, 1); + OP( DUP); + OP( DICT_VERIFY); /* * For each of the remaining dictionaries... */ - outLoop = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); - TclEmitInstInt4( INST_BEGIN_CATCH4, outLoop, envPtr); - ExceptionRangeStarts(envPtr, outLoop); - for (i=2 ; i<(int)parsePtr->numWords ; i++) { - /* - * Get the dictionary, and merge its pairs into the first dict (using - * a small loop). - */ + outLoop = MAKE_CATCH_RANGE(); + OP4( BEGIN_CATCH, outLoop); + CATCH_RANGE(outLoop) { + for (i=2 ; i<numWords ; i++) { + Tcl_BytecodeLabel haveNext, noNext; + /* + * Get the dictionary, and merge its pairs into the first dict (using + * a small loop). + */ + + tokenPtr = TokenAfter(tokenPtr); + PUSH_TOKEN( tokenPtr, i); + OP4( DICT_FIRST, infoIndex); + FWDJUMP( JUMP_TRUE, noNext); + BACKLABEL( haveNext); + OP( SWAP); + OP( DICT_PUT); + OP4( DICT_NEXT, infoIndex); + BACKJUMP( JUMP_FALSE, haveNext); + FWDLABEL( noNext); + OP( POP); + OP( POP); + OP14( UNSET_SCALAR, 0, infoIndex); + } + } + OP( END_CATCH); - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, i); - TclEmitInstInt4( INST_DICT_FIRST, infoIndex, envPtr); - TclEmitInstInt1( INST_JUMP_TRUE1, 24, envPtr); - TclEmitInstInt4( INST_REVERSE, 2, envPtr); - TclEmitInstInt4( INST_DICT_SET, 1, envPtr); - TclEmitInt4( workerIndex, envPtr); - TclAdjustStackDepth(-1, envPtr); - TclEmitOpcode( INST_POP, envPtr); - TclEmitInstInt4( INST_DICT_NEXT, infoIndex, envPtr); - TclEmitInstInt1( INST_JUMP_FALSE1, -20, envPtr); - TclEmitOpcode( INST_POP, envPtr); - TclEmitOpcode( INST_POP, envPtr); - TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); - TclEmitInt4( infoIndex, envPtr); - } - ExceptionRangeEnds(envPtr, outLoop); - TclEmitOpcode( INST_END_CATCH, envPtr); /* * Clean up any state left over. */ - Emit14Inst( INST_LOAD_SCALAR, workerIndex, envPtr); - TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); - TclEmitInt4( workerIndex, envPtr); - TclEmitInstInt1( INST_JUMP1, 18, envPtr); + FWDJUMP( JUMP, end); + STKDELTA(-1); /* * If an exception happens when starting to iterate over the second (and * subsequent) dicts. This is strictly not necessary, but it is nice. */ - TclAdjustStackDepth(-1, envPtr); - ExceptionRangeTarget(envPtr, outLoop, catchOffset); - TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); - TclEmitOpcode( INST_PUSH_RESULT, envPtr); - TclEmitOpcode( INST_END_CATCH, envPtr); - TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); - TclEmitInt4( workerIndex, envPtr); - TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); - TclEmitInt4( infoIndex, envPtr); - TclEmitOpcode( INST_RETURN_STK, envPtr); - + CATCH_TARGET(outLoop); + OP( PUSH_RETURN_OPTIONS); + OP( PUSH_RESULT); + OP( END_CATCH); + OP14( UNSET_SCALAR, 0, infoIndex); + INVOKE( RETURN_STK); + FWDLABEL( end); return TCL_OK; } @@ -1601,12 +1628,11 @@ CompileDictEachCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *varsTokenPtr, *dictTokenPtr, *bodyTokenPtr; - int keyVarIndex, valueVarIndex, nameChars, loopRange, catchRange; - int infoIndex, jumpDisplacement, bodyTargetOffset, emptyTargetOffset; - Tcl_Size numVars; - int endTargetOffset; - int collectVar = -1; /* Index of temp var holding the result - * dict. */ + Tcl_LVTIndex keyVarIndex, valueVarIndex, infoIndex; + Tcl_LVTIndex collectVar = TCL_INDEX_NONE; + Tcl_Size nameChars, numVars; + Tcl_ExceptionRange loopRange, catchRange; + Tcl_BytecodeLabel bodyTarget, emptyTarget, endTarget; const char **argv; Tcl_DString buffer; @@ -1617,6 +1643,9 @@ CompileDictEachCmd( if (parsePtr->numWords != 4) { return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } + if (!EnvIsProc(envPtr)) { + return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); + } varsTokenPtr = TokenAfter(parsePtr->tokenPtr); dictTokenPtr = TokenAfter(varsTokenPtr); @@ -1686,9 +1715,9 @@ CompileDictEachCmd( */ if (collect == TCL_EACH_COLLECT) { - PushStringLiteral(envPtr, ""); - Emit14Inst( INST_STORE_SCALAR, collectVar, envPtr); - TclEmitOpcode( INST_POP, envPtr); + PUSH( ""); + OP4( STORE_SCALAR, collectVar); + OP( POP); } /* @@ -1696,59 +1725,49 @@ CompileDictEachCmd( * this point. */ - CompileWord(envPtr, dictTokenPtr, interp, 2); + PUSH_TOKEN( dictTokenPtr, 2); /* * Now we catch errors from here on so that we can finalize the search * started by Tcl_DictObjFirst above. */ - catchRange = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); - TclEmitInstInt4( INST_BEGIN_CATCH4, catchRange, envPtr); - ExceptionRangeStarts(envPtr, catchRange); - - TclEmitInstInt4( INST_DICT_FIRST, infoIndex, envPtr); - emptyTargetOffset = CurrentOffset(envPtr); - TclEmitInstInt4( INST_JUMP_TRUE4, 0, envPtr); + catchRange = MAKE_CATCH_RANGE(); + OP4( BEGIN_CATCH, catchRange); + CATCH_RANGE(catchRange) { + OP4( DICT_FIRST, infoIndex); + FWDJUMP( JUMP_TRUE, emptyTarget); - /* - * Inside the iteration, write the loop variables. - */ + /* + * Inside the iteration, write the loop variables. + */ - bodyTargetOffset = CurrentOffset(envPtr); - Emit14Inst( INST_STORE_SCALAR, keyVarIndex, envPtr); - TclEmitOpcode( INST_POP, envPtr); - Emit14Inst( INST_STORE_SCALAR, valueVarIndex, envPtr); - TclEmitOpcode( INST_POP, envPtr); + BACKLABEL( bodyTarget); + OP4( STORE_SCALAR, keyVarIndex); + OP( POP); + OP4( STORE_SCALAR, valueVarIndex); + OP( POP); - /* - * Set up the loop exception targets. - */ + /* + * Set up the loop exception targets. + */ - loopRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); - ExceptionRangeStarts(envPtr, loopRange); + loopRange = MAKE_LOOP_RANGE(); - /* - * Compile the loop body itself. It should be stack-neutral. - */ + /* + * Compile the loop body itself. It should be stack-neutral. + */ - BODY(bodyTokenPtr, 3); - if (collect == TCL_EACH_COLLECT) { - Emit14Inst( INST_LOAD_SCALAR, keyVarIndex, envPtr); - TclEmitInstInt4(INST_OVER, 1, envPtr); - TclEmitInstInt4(INST_DICT_SET, 1, envPtr); - TclEmitInt4( collectVar, envPtr); - TclAdjustStackDepth(-1, envPtr); - TclEmitOpcode( INST_POP, envPtr); + CATCH_RANGE(loopRange) { + BODY( bodyTokenPtr, 3); + if (collect == TCL_EACH_COLLECT) { + OP4( LOAD_SCALAR, keyVarIndex); + OP( SWAP); + OP44( DICT_SET, 1, collectVar); + } + OP( POP); + } } - TclEmitOpcode( INST_POP, envPtr); - - /* - * Both exception target ranges (error and loop) end here. - */ - - ExceptionRangeEnds(envPtr, loopRange); - ExceptionRangeEnds(envPtr, catchRange); /* * Continue (or just normally process) by getting the next pair of items @@ -1756,30 +1775,26 @@ CompileDictEachCmd( * variables if there is another pair. */ - ExceptionRangeTarget(envPtr, loopRange, continueOffset); - TclEmitInstInt4( INST_DICT_NEXT, infoIndex, envPtr); - jumpDisplacement = bodyTargetOffset - CurrentOffset(envPtr); - TclEmitInstInt4( INST_JUMP_FALSE4, jumpDisplacement, envPtr); - endTargetOffset = CurrentOffset(envPtr); - TclEmitInstInt1( INST_JUMP1, 0, envPtr); + CONTINUE_TARGET( loopRange); + OP4( DICT_NEXT, infoIndex); + BACKJUMP( JUMP_FALSE, bodyTarget); + FWDJUMP( JUMP, endTarget); + STKDELTA(-1); /* * Error handler "finally" clause, which force-terminates the iteration * and re-throws the error. */ - TclAdjustStackDepth(-1, envPtr); - ExceptionRangeTarget(envPtr, catchRange, catchOffset); - TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); - TclEmitOpcode( INST_PUSH_RESULT, envPtr); - TclEmitOpcode( INST_END_CATCH, envPtr); - TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); - TclEmitInt4( infoIndex, envPtr); + CATCH_TARGET( catchRange); + OP( PUSH_RETURN_OPTIONS); + OP( PUSH_RESULT); + OP( END_CATCH); + OP14( UNSET_SCALAR, 0, infoIndex); if (collect == TCL_EACH_COLLECT) { - TclEmitInstInt1(INST_UNSET_SCALAR, 0, envPtr); - TclEmitInt4( collectVar, envPtr); + OP14( UNSET_SCALAR, 0, collectVar); } - TclEmitOpcode( INST_RETURN_STK, envPtr); + INVOKE( RETURN_STK); /* * Otherwise we're done (the jump after the DICT_FIRST points here) and we @@ -1787,17 +1802,13 @@ CompileDictEachCmd( * easy!) Note that we skip the END_CATCH. [Bug 1382528] */ - jumpDisplacement = CurrentOffset(envPtr) - emptyTargetOffset; - TclUpdateInstInt4AtPc(INST_JUMP_TRUE4, jumpDisplacement, - envPtr->codeStart + emptyTargetOffset); - jumpDisplacement = CurrentOffset(envPtr) - endTargetOffset; - TclUpdateInstInt1AtPc(INST_JUMP1, jumpDisplacement, - envPtr->codeStart + endTargetOffset); - TclEmitOpcode( INST_POP, envPtr); - TclEmitOpcode( INST_POP, envPtr); - ExceptionRangeTarget(envPtr, loopRange, breakOffset); - TclFinalizeLoopExceptionRange(envPtr, loopRange); - TclEmitOpcode( INST_END_CATCH, envPtr); + FWDLABEL( emptyTarget); + FWDLABEL( endTarget); + OP( POP); + OP( POP); + BREAK_TARGET( loopRange); + FINALIZE_LOOP(loopRange); + OP( END_CATCH); /* * Final stage of the command (normal case) is that we push an empty @@ -1805,14 +1816,12 @@ CompileDictEachCmd( * last to promote peephole optimization when it's dropped immediately. */ - TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); - TclEmitInt4( infoIndex, envPtr); + OP14( UNSET_SCALAR, 0, infoIndex); if (collect == TCL_EACH_COLLECT) { - Emit14Inst( INST_LOAD_SCALAR, collectVar, envPtr); - TclEmitInstInt1(INST_UNSET_SCALAR, 0, envPtr); - TclEmitInt4( collectVar, envPtr); + OP4( LOAD_SCALAR, collectVar); + OP14( UNSET_SCALAR, 0, collectVar); } else { - PushStringLiteral(envPtr, ""); + PUSH( ""); } return TCL_OK; } @@ -1827,16 +1836,19 @@ TclCompileDictUpdateCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ - int i, dictIndex, numVars, range, infoIndex; + Tcl_Size i, numVars, numWords = parsePtr->numWords; + Tcl_AuxDataRef infoIndex; + Tcl_LVTIndex dictIndex; + Tcl_ExceptionRange range; + Tcl_BytecodeLabel done; Tcl_Token **keyTokenPtrs, *dictVarTokenPtr, *bodyTokenPtr, *tokenPtr; DictUpdateInfo *duiPtr; - JumpFixup jumpFixup; /* * There must be at least one argument after the command. */ - if ((int)parsePtr->numWords < 5) { + if (numWords < 5 || numWords > UINT_MAX) { return TCL_ERROR; } @@ -1845,10 +1857,10 @@ TclCompileDictUpdateCmd( * dict update <lit(eral)> <any> <lit> ?<any> <lit> ...? <lit> */ - if (((int)parsePtr->numWords - 1) & 1) { + if ((numWords - 1) & 1) { return TCL_ERROR; } - numVars = (parsePtr->numWords - 3) / 2; + numVars = (numWords - 3) / 2; /* * The dictionary variable must be a local scalar that is knowable at @@ -1868,9 +1880,11 @@ TclCompileDictUpdateCmd( * that are to be used. */ - duiPtr = (DictUpdateInfo *)Tcl_Alloc(offsetof(DictUpdateInfo, varIndices) + sizeof(size_t) * numVars); + duiPtr = (DictUpdateInfo *)Tcl_Alloc( + offsetof(DictUpdateInfo, varIndices) + sizeof(size_t) * numVars); duiPtr->length = numVars; - keyTokenPtrs = (Tcl_Token **)TclStackAlloc(interp, sizeof(Tcl_Token *) * numVars); + keyTokenPtrs = (Tcl_Token **)TclStackAlloc(interp, + sizeof(Tcl_Token *) * numVars); tokenPtr = TokenAfter(dictVarTokenPtr); for (i=0 ; i<numVars ; i++) { @@ -1905,34 +1919,31 @@ TclCompileDictUpdateCmd( infoIndex = TclCreateAuxData(duiPtr, &dictUpdateInfoType, envPtr); for (i=0 ; i<numVars ; i++) { - CompileWord(envPtr, keyTokenPtrs[i], interp, 2*i+2); + PUSH_TOKEN( keyTokenPtrs[i], 2*i + 2); } - TclEmitInstInt4( INST_LIST, numVars, envPtr); - TclEmitInstInt4( INST_DICT_UPDATE_START, dictIndex, envPtr); - TclEmitInt4( infoIndex, envPtr); + OP4( LIST, numVars); + OP44( DICT_UPDATE_START, dictIndex, infoIndex); - range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); - TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); - - ExceptionRangeStarts(envPtr, range); - BODY(bodyTokenPtr, parsePtr->numWords - 1); - ExceptionRangeEnds(envPtr, range); + range = MAKE_CATCH_RANGE(); + OP4( BEGIN_CATCH, range); + CATCH_RANGE(range) { + BODY( bodyTokenPtr, numWords - 1); + } /* * Normal termination code: the stack has the key list below the result of * the body evaluation: swap them and finish the update code. */ - TclEmitOpcode( INST_END_CATCH, envPtr); - TclEmitInstInt4( INST_REVERSE, 2, envPtr); - TclEmitInstInt4( INST_DICT_UPDATE_END, dictIndex, envPtr); - TclEmitInt4( infoIndex, envPtr); + OP( END_CATCH); + OP( SWAP); + OP44( DICT_UPDATE_END, dictIndex, infoIndex); /* * Jump around the exceptional termination code. */ - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); + FWDJUMP( JUMP, done); /* * Termination code for non-ok returns: stash the result and return @@ -1940,20 +1951,16 @@ TclCompileDictUpdateCmd( * and finally return with the caught return data */ - ExceptionRangeTarget(envPtr, range, catchOffset); - TclEmitOpcode( INST_PUSH_RESULT, envPtr); - TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); - TclEmitOpcode( INST_END_CATCH, envPtr); - TclEmitInstInt4( INST_REVERSE, 3, envPtr); + CATCH_TARGET( range); + OP( PUSH_RESULT); + OP( PUSH_RETURN_OPTIONS); + OP( END_CATCH); + OP4( REVERSE, 3); - TclEmitInstInt4( INST_DICT_UPDATE_END, dictIndex, envPtr); - TclEmitInt4( infoIndex, envPtr); - TclEmitInvoke(envPtr,INST_RETURN_STK); + OP44( DICT_UPDATE_END, dictIndex, infoIndex); + INVOKE( RETURN_STK); + FWDLABEL( done); - if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) { - Tcl_Panic("TclCompileDictCmd(update): bad jump distance %" TCL_Z_MODIFIER "d", - CurrentOffset(envPtr) - jumpFixup.codeOffset); - } TclStackFree(interp, keyTokenPtrs); return TCL_OK; @@ -1979,16 +1986,18 @@ TclCompileDictAppendCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - int i, dictVarIndex; + Tcl_Size i, numWords = parsePtr->numWords; + Tcl_LVTIndex dictVarIndex; /* * There must be at least two argument after the command. And we impose an * (arbitrary) safe limit; anyone exceeding it should stop worrying about * speed quite so much. ;-) + * TODO: Raise the limit... */ /* TODO: Consider support for compiling expanded args. */ - if ((int)parsePtr->numWords<4 || (int)parsePtr->numWords>100) { + if (numWords < 4 || numWords > 100) { return TCL_ERROR; } @@ -2007,19 +2016,19 @@ TclCompileDictAppendCmd( */ tokenPtr = TokenAfter(tokenPtr); - for (i=2 ; i<(int)parsePtr->numWords ; i++) { - CompileWord(envPtr, tokenPtr, interp, i); + for (i=2 ; i<numWords ; i++) { + PUSH_TOKEN( tokenPtr, i); tokenPtr = TokenAfter(tokenPtr); } - if ((int)parsePtr->numWords > 4) { - TclEmitInstInt1(INST_STR_CONCAT1, (int)parsePtr->numWords-3, envPtr); + if (numWords > 4) { + OP1( STR_CONCAT1, numWords - 3); } /* * Do the concatenation. */ - TclEmitInstInt4(INST_DICT_APPEND, dictVarIndex, envPtr); + OP4( DICT_APPEND, dictVarIndex); return TCL_OK; } @@ -2034,7 +2043,7 @@ TclCompileDictLappendCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr, *keyTokenPtr, *valueTokenPtr; - int dictVarIndex; + Tcl_LVTIndex dictVarIndex; /* * There must be three arguments after the command. @@ -2062,12 +2071,14 @@ TclCompileDictLappendCmd( * Issue the implementation. */ - CompileWord(envPtr, keyTokenPtr, interp, 2); - CompileWord(envPtr, valueTokenPtr, interp, 3); - TclEmitInstInt4( INST_DICT_LAPPEND, dictVarIndex, envPtr); + PUSH_TOKEN( keyTokenPtr, 2); + PUSH_TOKEN( valueTokenPtr, 3); + OP4( DICT_LAPPEND, dictVarIndex); return TCL_OK; } +/* Compile [dict with]. Delegates code issuing to IssueDictWithEmpty() and + * IssueDictWithBodied(). */ int TclCompileDictWithCmd( Tcl_Interp *interp, /* Used for looking up stuff. */ @@ -2077,19 +2088,16 @@ TclCompileDictWithCmd( * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { - DefineLineInformation; /* TIP #280 */ - int i, range, varNameTmp = -1, pathTmp = -1, keysTmp, gotPath; - int dictVar, bodyIsEmpty = 1; + int bodyIsEmpty = 1; + Tcl_Size i, numWords = parsePtr->numWords; Tcl_Token *varTokenPtr, *tokenPtr; - JumpFixup jumpFixup; - const char *ptr, *end; /* * There must be at least one argument after the command. */ /* TODO: Consider support for compiling expanded args. */ - if ((int)parsePtr->numWords < 3) { + if (numWords < 3 || numWords > UINT_MAX) { return TCL_ERROR; } @@ -2100,7 +2108,7 @@ TclCompileDictWithCmd( varTokenPtr = TokenAfter(parsePtr->tokenPtr); tokenPtr = TokenAfter(varTokenPtr); - for (i=3 ; i<(int)parsePtr->numWords ; i++) { + for (i=3 ; i<numWords ; i++) { tokenPtr = TokenAfter(tokenPtr); } if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { @@ -2113,105 +2121,160 @@ TclCompileDictWithCmd( * to hold the temporary variables (used to keep stack usage simple). */ - 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 TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, - envPtr); - } - bodyIsEmpty = 0; - break; + if (!TclIsEmptyToken(tokenPtr)) { + if (!EnvIsProc(envPtr)) { + return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, + envPtr); } + bodyIsEmpty = 0; } - /* - * Determine if we're manipulating a dict in a simple local variable. - */ + /* Now we commit to issuing code. */ - gotPath = ((int)parsePtr->numWords > 3); - dictVar = LocalScalarFromToken(varTokenPtr, envPtr); + if (bodyIsEmpty) { + /* + * Special case: an empty body means we definitely have no need to issue + * try-finally style code or to allocate local variable table entries + * for storing temporaries. Still need to do both INST_DICT_EXPAND and + * INST_DICT_RECOMBINE_* though, because we can't determine if we're + * free of traces. + */ + + IssueDictWithEmpty(interp, numWords, varTokenPtr, envPtr); + } else { + /* + * OK, we have a non-trivial body. This means that the focus is on + * generating a try-finally structure where the INST_DICT_RECOMBINE_* + * goes in the 'finally' clause. + */ + + IssueDictWithBodied(interp, numWords, varTokenPtr, envPtr); + } + return TCL_OK; +} + +/* + * Issue code for a special case of [dict with]: an empty body means we + * definitely have no need to issue try-finally style code or to allocate local + * variable table entries for storing temporaries. Still need to do both + * INST_DICT_EXPAND and INST_DICT_RECOMBINE_* though, because we can't + * determine if we're free of traces. + */ +static inline void +IssueDictWithEmpty( + Tcl_Interp *interp, + Tcl_Size numWords, + Tcl_Token *varTokenPtr, + CompileEnv *envPtr) +{ + Tcl_Token *tokenPtr; + DefineLineInformation; /* TIP #280 */ + int gotPath; + Tcl_Size i; + Tcl_LVTIndex dictVar; /* - * Special case: an empty body means we definitely have no need to issue - * try-finally style code or to allocate local variable table entries for - * storing temporaries. Still need to do both INST_DICT_EXPAND and - * INST_DICT_RECOMBINE_* though, because we can't determine if we're free - * of traces. + * Determine if we're manipulating a dict in a simple local variable. */ - if (bodyIsEmpty) { - if (dictVar >= 0) { - if (gotPath) { - /* - * Case: Path into dict in LVT with empty body. - */ + gotPath = (numWords > 3); + dictVar = LocalScalarFromToken(varTokenPtr, envPtr); - tokenPtr = TokenAfter(varTokenPtr); - for (i=2 ; i<(int)parsePtr->numWords-1 ; i++) { - CompileWord(envPtr, tokenPtr, interp, i); - tokenPtr = TokenAfter(tokenPtr); - } - TclEmitInstInt4(INST_LIST, (int)parsePtr->numWords-3,envPtr); - Emit14Inst( INST_LOAD_SCALAR, dictVar, envPtr); - TclEmitInstInt4(INST_OVER, 1, envPtr); - TclEmitOpcode( INST_DICT_EXPAND, envPtr); - TclEmitInstInt4(INST_DICT_RECOMBINE_IMM, dictVar, envPtr); - } else { - /* - * Case: Direct dict in LVT with empty body. - */ + if (dictVar >= 0) { + if (gotPath) { + /* + * Case: Path into dict in LVT with empty body. + */ - PushStringLiteral(envPtr, ""); - Emit14Inst( INST_LOAD_SCALAR, dictVar, envPtr); - PushStringLiteral(envPtr, ""); - TclEmitOpcode( INST_DICT_EXPAND, envPtr); - TclEmitInstInt4(INST_DICT_RECOMBINE_IMM, dictVar, envPtr); + tokenPtr = TokenAfter(varTokenPtr); + for (i=2 ; i<numWords-1 ; i++) { + PUSH_TOKEN( tokenPtr, i); + tokenPtr = TokenAfter(tokenPtr); } + OP4( LIST, numWords - 3); + OP4( LOAD_SCALAR, dictVar); + OP4( OVER, 1); + OP( DICT_EXPAND); + OP4( DICT_RECOMBINE_IMM, dictVar); } else { - if (gotPath) { - /* - * Case: Path into dict in non-simple var with empty body. - */ + /* + * Case: Direct dict in LVT with empty body. + */ - tokenPtr = varTokenPtr; - for (i=1 ; i<(int)parsePtr->numWords-1 ; i++) { - CompileWord(envPtr, tokenPtr, interp, i); - tokenPtr = TokenAfter(tokenPtr); - } - TclEmitInstInt4(INST_LIST, (int)parsePtr->numWords-3,envPtr); - TclEmitInstInt4(INST_OVER, 1, envPtr); - TclEmitOpcode( INST_LOAD_STK, envPtr); - TclEmitInstInt4(INST_OVER, 1, envPtr); - TclEmitOpcode( INST_DICT_EXPAND, envPtr); - TclEmitOpcode( INST_DICT_RECOMBINE_STK, envPtr); - } else { - /* - * Case: Direct dict in non-simple var with empty body. - */ + PUSH( ""); + OP4( LOAD_SCALAR, dictVar); + PUSH( ""); + OP( DICT_EXPAND); + OP4( DICT_RECOMBINE_IMM, dictVar); + } + } else { + if (gotPath) { + /* + * Case: Path into dict in non-simple var with empty body. + */ - CompileWord(envPtr, varTokenPtr, interp, 1); - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_LOAD_STK, envPtr); - PushStringLiteral(envPtr, ""); - TclEmitOpcode( INST_DICT_EXPAND, envPtr); - PushStringLiteral(envPtr, ""); - TclEmitInstInt4(INST_REVERSE, 2, envPtr); - TclEmitOpcode( INST_DICT_RECOMBINE_STK, envPtr); + tokenPtr = varTokenPtr; + for (i=1 ; i<numWords-1 ; i++) { + PUSH_TOKEN( tokenPtr, i); + tokenPtr = TokenAfter(tokenPtr); } + OP4( LIST, numWords - 3); + OP4( OVER, 1); + OP( LOAD_STK); + OP4( OVER, 1); + OP( DICT_EXPAND); + OP( DICT_RECOMBINE_STK); + } else { + /* + * Case: Direct dict in non-simple var with empty body. + */ + + PUSH_TOKEN( varTokenPtr, 1); + OP( DUP); + OP( LOAD_STK); + PUSH( ""); + OP( DICT_EXPAND); + PUSH( ""); + OP( SWAP); + OP( DICT_RECOMBINE_STK); } - PushStringLiteral(envPtr, ""); - return TCL_OK; } + PUSH( ""); +} +/* + * Issue code for a [dict with] that has a non-trivial body. The focus is on + * generating a try-finally structure where the INST_DICT_RECOMBINE_* goes + * in the 'finally' clause. + */ +static inline void +IssueDictWithBodied( + Tcl_Interp *interp, + Tcl_Size numWords, + Tcl_Token *varTokenPtr, + CompileEnv *envPtr) +{ /* - * OK, we have a non-trivial body. This means that the focus is on - * generating a try-finally structure where the INST_DICT_RECOMBINE_* goes - * in the 'finally' clause. - * * Start by allocating local (unnamed, untraced) working variables. */ - if (dictVar == -1) { + Tcl_LVTIndex dictVar, keysTmp; + Tcl_LVTIndex varNameTmp = TCL_INDEX_NONE, pathTmp = TCL_INDEX_NONE; + int gotPath; + Tcl_Size i; + Tcl_BytecodeLabel done; + Tcl_ExceptionRange range; + Tcl_Token *tokenPtr; + DefineLineInformation; /* TIP #280 */ + + /* + * Determine if we're manipulating a dict in a simple local variable. + */ + + gotPath = (numWords > 3); + dictVar = LocalScalarFromToken(varTokenPtr, envPtr); + + if (dictVar == TCL_INDEX_NONE) { varNameTmp = AnonymousLocal(envPtr); } if (gotPath) { @@ -2223,100 +2286,106 @@ TclCompileDictWithCmd( * Issue instructions. First, the part to expand the dictionary. */ - if (dictVar == -1) { - CompileWord(envPtr, varTokenPtr, interp, 1); - Emit14Inst( INST_STORE_SCALAR, varNameTmp, envPtr); + if (dictVar == TCL_INDEX_NONE) { + PUSH_TOKEN( varTokenPtr, 1); + OP4( STORE_SCALAR, varNameTmp); } tokenPtr = TokenAfter(varTokenPtr); if (gotPath) { - for (i=2 ; i<(int)parsePtr->numWords-1 ; i++) { - CompileWord(envPtr, tokenPtr, interp, i); + for (i=2 ; i<numWords-1 ; i++) { + PUSH_TOKEN( tokenPtr, i); tokenPtr = TokenAfter(tokenPtr); } - TclEmitInstInt4( INST_LIST, (int)parsePtr->numWords-3,envPtr); - Emit14Inst( INST_STORE_SCALAR, pathTmp, envPtr); - TclEmitOpcode( INST_POP, envPtr); - } - if (dictVar == -1) { - TclEmitOpcode( INST_LOAD_STK, envPtr); - } else { - Emit14Inst( INST_LOAD_SCALAR, dictVar, envPtr); - } - if (gotPath) { - Emit14Inst( INST_LOAD_SCALAR, pathTmp, envPtr); + OP4( LIST, numWords - 3); + OP4( STORE_SCALAR, pathTmp); + OP( POP); + if (dictVar == TCL_INDEX_NONE) { + OP( LOAD_STK); + } else { + OP4( LOAD_SCALAR, dictVar); + } + OP4( LOAD_SCALAR, pathTmp); } else { - PushStringLiteral(envPtr, ""); + if (dictVar == TCL_INDEX_NONE) { + OP( LOAD_STK); + } else { + OP4( LOAD_SCALAR, dictVar); + } + PUSH( ""); } - TclEmitOpcode( INST_DICT_EXPAND, envPtr); - Emit14Inst( INST_STORE_SCALAR, keysTmp, envPtr); - TclEmitOpcode( INST_POP, envPtr); + OP( DICT_EXPAND); + OP4( STORE_SCALAR, keysTmp); + OP( POP); /* * Now the body of the [dict with]. */ - range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); - TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr); - - ExceptionRangeStarts(envPtr, range); - BODY(tokenPtr, parsePtr->numWords - 1); - ExceptionRangeEnds(envPtr, range); + range = MAKE_CATCH_RANGE(); + OP4( BEGIN_CATCH, range); + CATCH_RANGE(range) { + BODY( tokenPtr, numWords - 1); + } + OP( END_CATCH); /* * Now fold the results back into the dictionary in the OK case. */ - TclEmitOpcode( INST_END_CATCH, envPtr); - if (dictVar == -1) { - Emit14Inst( INST_LOAD_SCALAR, varNameTmp, envPtr); - } - if (gotPath) { - Emit14Inst( INST_LOAD_SCALAR, pathTmp, envPtr); - } else { - PushStringLiteral(envPtr, ""); - } - Emit14Inst( INST_LOAD_SCALAR, keysTmp, envPtr); - if (dictVar == -1) { - TclEmitOpcode( INST_DICT_RECOMBINE_STK, envPtr); + if (dictVar == TCL_INDEX_NONE) { + OP4( LOAD_SCALAR, varNameTmp); + if (gotPath) { + OP4( LOAD_SCALAR, pathTmp); + } else { + PUSH( ""); + } + OP4( LOAD_SCALAR, keysTmp); + OP( DICT_RECOMBINE_STK); } else { - TclEmitInstInt4( INST_DICT_RECOMBINE_IMM, dictVar, envPtr); + if (gotPath) { + OP4( LOAD_SCALAR, pathTmp); + } else { + PUSH( ""); + } + OP4( LOAD_SCALAR, keysTmp); + OP4( DICT_RECOMBINE_IMM, dictVar); } - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); + FWDJUMP( JUMP, done); + STKDELTA(-1); /* * Now fold the results back into the dictionary in the exception case. */ - TclAdjustStackDepth(-1, envPtr); - ExceptionRangeTarget(envPtr, range, catchOffset); - TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); - TclEmitOpcode( INST_PUSH_RESULT, envPtr); - TclEmitOpcode( INST_END_CATCH, envPtr); - if (dictVar == -1) { - Emit14Inst( INST_LOAD_SCALAR, varNameTmp, envPtr); - } - if ((int)parsePtr->numWords > 3) { - Emit14Inst( INST_LOAD_SCALAR, pathTmp, envPtr); - } else { - PushStringLiteral(envPtr, ""); - } - Emit14Inst( INST_LOAD_SCALAR, keysTmp, envPtr); - if (dictVar == -1) { - TclEmitOpcode( INST_DICT_RECOMBINE_STK, envPtr); + CATCH_TARGET( range); + OP( PUSH_RETURN_OPTIONS); + OP( PUSH_RESULT); + OP( END_CATCH); + if (dictVar == TCL_INDEX_NONE) { + OP4( LOAD_SCALAR, varNameTmp); + if (numWords > 3) { + OP4( LOAD_SCALAR, pathTmp); + } else { + PUSH( ""); + } + OP4( LOAD_SCALAR, keysTmp); + OP( DICT_RECOMBINE_STK); } else { - TclEmitInstInt4( INST_DICT_RECOMBINE_IMM, dictVar, envPtr); + if (numWords > 3) { + OP4( LOAD_SCALAR, pathTmp); + } else { + PUSH( ""); + } + OP4( LOAD_SCALAR, keysTmp); + OP4( DICT_RECOMBINE_IMM, dictVar); } - TclEmitInvoke(envPtr, INST_RETURN_STK); + INVOKE( RETURN_STK); /* * Prepare for the start of the next command. */ - if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) { - Tcl_Panic("TclCompileDictCmd(update): bad jump distance %" TCL_Z_MODIFIER "d", - CurrentOffset(envPtr) - jumpFixup.codeOffset); - } - return TCL_OK; + FWDLABEL( done); } /* @@ -2350,7 +2419,8 @@ DupDictUpdateInfo( size_t len; dui1Ptr = (DictUpdateInfo *)clientData; - len = offsetof(DictUpdateInfo, varIndices) + sizeof(size_t) * dui1Ptr->length; + len = offsetof(DictUpdateInfo, varIndices) + + sizeof(size_t) * dui1Ptr->length; dui2Ptr = (DictUpdateInfo *)Tcl_Alloc(len); memcpy(dui2Ptr, dui1Ptr, len); return dui2Ptr; @@ -2374,10 +2444,9 @@ PrintDictUpdateInfo( Tcl_Size i; for (i=0 ; i<duiPtr->length ; i++) { - if (i) { - Tcl_AppendToObj(appendObj, ", ", -1); - } - Tcl_AppendPrintfToObj(appendObj, "%%v%" TCL_Z_MODIFIER "u", duiPtr->varIndices[i]); + Tcl_AppendPrintfToObj(appendObj, "%s%%v%" TCL_Z_MODIFIER "u", + (i ? ", " : ""), + duiPtr->varIndices[i]); } } @@ -2428,12 +2497,13 @@ TclCompileErrorCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; + Tcl_Size numWords = parsePtr->numWords; /* * General syntax: [error message ?errorInfo? ?errorCode?] */ - if ((int)parsePtr->numWords < 2 || (int)parsePtr->numWords > 4) { + if (numWords < 2 || numWords > 4) { return TCL_ERROR; } @@ -2442,25 +2512,23 @@ TclCompileErrorCmd( */ tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); + PUSH_TOKEN( tokenPtr, 1); /* * Construct the options. Note that -code and -level are not here. */ - if (parsePtr->numWords == 2) { - PushStringLiteral(envPtr, ""); - } else { - PushStringLiteral(envPtr, "-errorinfo"); + PUSH( ""); + if (numWords > 2) { tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 2); - if (parsePtr->numWords == 3) { - TclEmitInstInt4( INST_LIST, 2, envPtr); - } else { - PushStringLiteral(envPtr, "-errorcode"); + PUSH( "-errorinfo"); + PUSH_TOKEN( tokenPtr, 2); + OP( DICT_PUT); + if (numWords > 3) { tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 3); - TclEmitInstInt4( INST_LIST, 4, envPtr); + PUSH( "-errorcode"); + PUSH_TOKEN( tokenPtr, 3); + OP( DICT_PUT); } } @@ -2468,8 +2536,7 @@ TclCompileErrorCmd( * Issue the error via 'returnImm error 0'. */ - TclEmitInstInt4( INST_RETURN_IMM, TCL_ERROR, envPtr); - TclEmitInt4( 0, envPtr); + OP44( RETURN_IMM, TCL_ERROR, 0); return TCL_OK; } @@ -2501,7 +2568,7 @@ TclCompileExprCmd( { Tcl_Token *firstWordPtr; - if (parsePtr->numWords == 1) { + if (parsePtr->numWords == 1 || parsePtr->numWords > UINT_MAX) { return TCL_ERROR; } @@ -2510,10 +2577,10 @@ TclCompileExprCmd( */ envPtr->line = envPtr->extCmdMapPtr->loc[ - envPtr->extCmdMapPtr->nuloc-1].line[1]; + envPtr->extCmdMapPtr->nuloc - 1].line[1]; firstWordPtr = TokenAfter(parsePtr->tokenPtr); - TclCompileExprWords(interp, firstWordPtr, (int)parsePtr->numWords-1, envPtr); + TclCompileExprWords(interp, firstWordPtr, parsePtr->numWords - 1, envPtr); return TCL_OK; } @@ -2545,9 +2612,8 @@ TclCompileForCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *startTokenPtr, *testTokenPtr, *nextTokenPtr, *bodyTokenPtr; - JumpFixup jumpEvalCondFixup; - int bodyCodeOffset, nextCodeOffset, jumpDist; - int bodyRange, nextRange; + Tcl_ExceptionRange bodyRange, nextRange = -1; + Tcl_BytecodeLabel evalBody, testCondition; if (parsePtr->numWords != 5) { return TCL_ERROR; @@ -2581,8 +2647,8 @@ TclCompileForCmd( * Inline compile the initial command. */ - BODY(startTokenPtr, 1); - TclEmitOpcode(INST_POP, envPtr); + BODY( startTokenPtr, 1); + OP( POP); /* * Jump to the evaluation of the condition. This code uses the "loop @@ -2596,17 +2662,18 @@ TclCompileForCmd( * if (result) goto B */ - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpEvalCondFixup); + FWDJUMP( JUMP, testCondition); /* * Compile the loop body. */ - bodyRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); - bodyCodeOffset = ExceptionRangeStarts(envPtr, bodyRange); - BODY(bodyTokenPtr, 4); - ExceptionRangeEnds(envPtr, bodyRange); - TclEmitOpcode(INST_POP, envPtr); + bodyRange = MAKE_LOOP_RANGE(); + BACKLABEL( evalBody); + CATCH_RANGE(bodyRange) { + BODY( bodyTokenPtr, 4); + } + OP( POP); /* * Compile the "next" subcommand. Note that this exception range will not @@ -2614,54 +2681,42 @@ TclCompileForCmd( * TCL_CONTINUE but rather just TCL_BREAK. */ - nextRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); - envPtr->exceptAuxArrayPtr[nextRange].supportsContinue = 0; - nextCodeOffset = ExceptionRangeStarts(envPtr, nextRange); - BODY(nextTokenPtr, 3); - ExceptionRangeEnds(envPtr, nextRange); - TclEmitOpcode(INST_POP, envPtr); + CONTINUE_TARGET( bodyRange); + if (!TclIsEmptyToken(nextTokenPtr)) { + nextRange = MAKE_LOOP_RANGE(); + envPtr->exceptAuxArrayPtr[nextRange].supportsContinue = 0; + CATCH_RANGE(nextRange) { + BODY( nextTokenPtr, 3); + } + OP( POP); + } /* * Compile the test expression then emit the conditional jump that * terminates the for. */ - if (TclFixupForwardJumpToHere(envPtr, &jumpEvalCondFixup, 127)) { - bodyCodeOffset += 3; - nextCodeOffset += 3; - } - - SetLineInformation(2); - TclCompileExprWords(interp, testTokenPtr, 1, envPtr); - - jumpDist = CurrentOffset(envPtr) - bodyCodeOffset; - if (jumpDist > 127) { - TclEmitInstInt4(INST_JUMP_TRUE4, -jumpDist, envPtr); - } else { - TclEmitInstInt1(INST_JUMP_TRUE1, -jumpDist, envPtr); - } + FWDLABEL( testCondition); + PUSH_EXPR_TOKEN( testTokenPtr, 2); + BACKJUMP( JUMP_TRUE, evalBody); /* * Fix the starting points of the exception ranges (may have moved due to * jump type modification) and set where the exceptions target. */ - envPtr->exceptArrayPtr[bodyRange].codeOffset = bodyCodeOffset; - envPtr->exceptArrayPtr[bodyRange].continueOffset = nextCodeOffset; - - envPtr->exceptArrayPtr[nextRange].codeOffset = nextCodeOffset; - - ExceptionRangeTarget(envPtr, bodyRange, breakOffset); - ExceptionRangeTarget(envPtr, nextRange, breakOffset); - TclFinalizeLoopExceptionRange(envPtr, bodyRange); - TclFinalizeLoopExceptionRange(envPtr, nextRange); + BREAK_TARGET( bodyRange); + FINALIZE_LOOP(bodyRange); + if (nextRange != -1) { + BREAK_TARGET( nextRange); + FINALIZE_LOOP(nextRange); + } /* * The for command's result is an empty string. */ - PushStringLiteral(envPtr, ""); - + PUSH( ""); return TCL_OK; } @@ -2756,15 +2811,15 @@ CompileEachloopCmd( * (TCL_EACH_*) */ { DefineLineInformation; /* TIP #280 */ - Proc *procPtr = envPtr->procPtr; ForeachInfo *infoPtr=NULL; /* Points to the structure describing this * foreach command. Stored in a AuxData * record in the ByteCode. */ Tcl_Token *tokenPtr, *bodyTokenPtr; - int jumpBackOffset, infoIndex, range; - int numWords, numLists, i, code = TCL_OK; - Tcl_Size j; + Tcl_Size jumpBackOffset, numWords, numLists, i, j; + Tcl_AuxDataRef infoIndex; + Tcl_ExceptionRange range; + int code = TCL_OK; Tcl_Obj *varListObj = NULL; /* @@ -2772,12 +2827,12 @@ CompileEachloopCmd( * the payoff is too small. */ - if (procPtr == NULL) { + if (!EnvIsProc(envPtr)) { return TCL_ERROR; } - numWords = (int)parsePtr->numWords; - if ((numWords < 4) || (numWords%2 != 0)) { + numWords = parsePtr->numWords; + if ((numWords < 4) || (numWords > UINT_MAX) || (numWords%2 != 0)) { return TCL_ERROR; } @@ -2838,13 +2893,13 @@ CompileEachloopCmd( varListPtr = (ForeachVarList *)Tcl_Alloc(offsetof(ForeachVarList, varIndexes) + numVars * sizeof(varListPtr->varIndexes[0])); varListPtr->numVars = numVars; - infoPtr->varLists[i/2] = varListPtr; + infoPtr->varLists[i / 2] = varListPtr; infoPtr->numLists++; for (j = 0; j < numVars; j++) { Tcl_Obj *varNameObj; const char *bytes; - int varIndex; + Tcl_LVTIndex varIndex; Tcl_Size length; Tcl_ListObjIndex(NULL, varListObj, j, &varNameObj); @@ -2870,7 +2925,7 @@ CompileEachloopCmd( */ if (collect == TCL_EACH_COLLECT) { - TclEmitInstInt4(INST_LIST, 0, envPtr); + OP4( LIST, 0); } /* @@ -2881,26 +2936,26 @@ CompileEachloopCmd( i < numWords-1; i++, tokenPtr = TokenAfter(tokenPtr)) { if ((i%2 == 0) && (i > 0)) { - CompileWord(envPtr, tokenPtr, interp, i); + PUSH_TOKEN( tokenPtr, i); } } - TclEmitInstInt4(INST_FOREACH_START, infoIndex, envPtr); + OP4( FOREACH_START, infoIndex); /* * Inline compile the loop body. */ - range = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); + range = MAKE_LOOP_RANGE(); - ExceptionRangeStarts(envPtr, range); - BODY(bodyTokenPtr, numWords - 1); - ExceptionRangeEnds(envPtr, range); + CATCH_RANGE(range) { + BODY( bodyTokenPtr, numWords - 1); + } if (collect == TCL_EACH_COLLECT) { - TclEmitOpcode(INST_LMAP_COLLECT, envPtr); + OP( LMAP_COLLECT); } else { - TclEmitOpcode( INST_POP, envPtr); + OP( POP); } /* @@ -2908,12 +2963,12 @@ CompileEachloopCmd( * to terminate the loop. Set the loop's break target. */ - ExceptionRangeTarget(envPtr, range, continueOffset); - TclEmitOpcode(INST_FOREACH_STEP, envPtr); - ExceptionRangeTarget(envPtr, range, breakOffset); - TclFinalizeLoopExceptionRange(envPtr, range); - TclEmitOpcode(INST_FOREACH_END, envPtr); - TclAdjustStackDepth(-(numLists+2), envPtr); + CONTINUE_TARGET( range); + OP( FOREACH_STEP); + BREAK_TARGET( range); + FINALIZE_LOOP(range); + OP( FOREACH_END); + STKDELTA(-(numLists + 2)); /* * Set the jumpback distance from INST_FOREACH_STEP to the start of the @@ -2930,10 +2985,10 @@ CompileEachloopCmd( */ if (collect != TCL_EACH_COLLECT) { - PushStringLiteral(envPtr, ""); + PUSH( ""); } - done: + done: if (code == TCL_ERROR) { FreeForeachInfo(infoPtr); } @@ -2964,13 +3019,13 @@ CompileEachloopCmd( static void * DupForeachInfo( - void *clientData) /* The foreach command's compilation auxiliary + void *clientData) /* The foreach command's compilation auxiliary * data to duplicate. */ { ForeachInfo *srcPtr = (ForeachInfo *)clientData; ForeachInfo *dupPtr; ForeachVarList *srcListPtr, *dupListPtr; - int numVars, i, j, numLists = srcPtr->numLists; + Tcl_Size numVars, i, j, numLists = srcPtr->numLists; dupPtr = (ForeachInfo *)Tcl_Alloc(offsetof(ForeachInfo, varLists) + numLists * sizeof(ForeachVarList *)); @@ -3013,12 +3068,12 @@ DupForeachInfo( static void FreeForeachInfo( - void *clientData) /* The foreach command's compilation auxiliary + void *clientData) /* The foreach command's compilation auxiliary * data to free. */ { ForeachInfo *infoPtr = (ForeachInfo *)clientData; ForeachVarList *listPtr; - size_t i, numLists = infoPtr->numLists; + Tcl_Size i, numLists = infoPtr->numLists; for (i = 0; i < numLists; i++) { listPtr = infoPtr->varLists[i]; @@ -3055,11 +3110,11 @@ PrintForeachInfo( ForeachVarList *varsPtr; Tcl_Size i, j; - Tcl_AppendToObj(appendObj, "data=[", -1); + Tcl_AppendToObj(appendObj, "data=[", TCL_AUTO_LENGTH); for (i=0 ; i<infoPtr->numLists ; i++) { if (i) { - Tcl_AppendToObj(appendObj, ", ", -1); + Tcl_AppendToObj(appendObj, ", ", TCL_AUTO_LENGTH); } Tcl_AppendPrintfToObj(appendObj, "%%v%" TCL_Z_MODIFIER "u", (infoPtr->firstValueTemp + i)); @@ -3068,19 +3123,19 @@ PrintForeachInfo( infoPtr->loopCtTemp); for (i=0 ; i<infoPtr->numLists ; i++) { if (i) { - Tcl_AppendToObj(appendObj, ",", -1); + Tcl_AppendToObj(appendObj, ",", TCL_AUTO_LENGTH); } Tcl_AppendPrintfToObj(appendObj, "\n\t\t it%%v%" TCL_Z_MODIFIER "u\t[", (infoPtr->firstValueTemp + i)); varsPtr = infoPtr->varLists[i]; for (j=0 ; j<varsPtr->numVars ; j++) { if (j) { - Tcl_AppendToObj(appendObj, ", ", -1); + Tcl_AppendToObj(appendObj, ", ", TCL_AUTO_LENGTH); } Tcl_AppendPrintfToObj(appendObj, "%%v%" TCL_Z_MODIFIER "u", varsPtr->varIndexes[j]); } - Tcl_AppendToObj(appendObj, "]", -1); + Tcl_AppendToObj(appendObj, "]", TCL_AUTO_LENGTH); } } @@ -3099,18 +3154,18 @@ PrintNewForeachInfo( infoPtr->loopCtTemp); for (i=0 ; i<infoPtr->numLists ; i++) { if (i) { - Tcl_AppendToObj(appendObj, ",", -1); + Tcl_AppendToObj(appendObj, ",", TCL_AUTO_LENGTH); } - Tcl_AppendToObj(appendObj, "[", -1); + Tcl_AppendToObj(appendObj, "[", TCL_AUTO_LENGTH); varsPtr = infoPtr->varLists[i]; for (j=0 ; j<varsPtr->numVars ; j++) { if (j) { - Tcl_AppendToObj(appendObj, ",", -1); + Tcl_AppendToObj(appendObj, ",", TCL_AUTO_LENGTH); } Tcl_AppendPrintfToObj(appendObj, "%%v%" TCL_Z_MODIFIER "u", varsPtr->varIndexes[j]); } - Tcl_AppendToObj(appendObj, "]", -1); + Tcl_AppendToObj(appendObj, "]", TCL_AUTO_LENGTH); } } @@ -3227,14 +3282,14 @@ TclCompileFormatCmd( Tcl_Token *tokenPtr = parsePtr->tokenPtr; Tcl_Obj **objv, *formatObj, *tmpObj; const char *bytes, *start; - int i, j; - Tcl_Size len; + Tcl_Size i, j, numWords = parsePtr->numWords; + /* TODO: Consider support for compiling expanded args. */ /* * Don't handle any guaranteed-error cases. */ - if ((int)parsePtr->numWords < 2) { + if (numWords < 2 || numWords > UINT_MAX) { return TCL_ERROR; } @@ -3251,8 +3306,9 @@ TclCompileFormatCmd( return TCL_ERROR; } - objv = (Tcl_Obj **)Tcl_Alloc(((int)parsePtr->numWords-2) * sizeof(Tcl_Obj *)); - for (i=0 ; i+2 < (int)parsePtr->numWords ; i++) { + objv = (Tcl_Obj **)TclStackAlloc(interp, + (numWords - 2) * sizeof(Tcl_Obj *)); + for (i=0 ; i+2 < numWords ; i++) { tokenPtr = TokenAfter(tokenPtr); TclNewObj(objv[i]); Tcl_IncrRefCount(objv[i]); @@ -3266,12 +3322,11 @@ TclCompileFormatCmd( * the format is broken). Do the format now. */ - tmpObj = Tcl_Format(interp, TclGetString(formatObj), - (int)parsePtr->numWords-2, objv); + tmpObj = Tcl_Format(interp, TclGetString(formatObj), numWords - 2, objv); for (; --i>=0 ;) { Tcl_DecrRefCount(objv[i]); } - Tcl_Free(objv); + TclStackFree(interp, objv); Tcl_DecrRefCount(formatObj); if (tmpObj == NULL) { TclCompileSyntaxError(interp, envPtr); @@ -3283,9 +3338,7 @@ TclCompileFormatCmd( * literal. Job done. */ - bytes = TclGetStringFromObj(tmpObj, &len); - PushLiteral(envPtr, bytes, len); - Tcl_DecrRefCount(tmpObj); + PUSH_OBJ( tmpObj); return TCL_OK; checkForStringConcatCase: @@ -3301,7 +3354,7 @@ TclCompileFormatCmd( for (; i>=0 ; i--) { Tcl_DecrRefCount(objv[i]); } - Tcl_Free(objv); + TclStackFree(interp, objv); tokenPtr = TokenAfter(parsePtr->tokenPtr); tokenPtr = TokenAfter(tokenPtr); i = 0; @@ -3328,7 +3381,7 @@ TclCompileFormatCmd( * Check if the number of things to concatenate will fit in a byte. */ - if (i+2 != (int)parsePtr->numWords || i > 125) { + if (i+2 != numWords || i > 125) { Tcl_DecrRefCount(formatObj); return TCL_ERROR; } @@ -3346,7 +3399,7 @@ TclCompileFormatCmd( start = TclGetString(formatObj); /* The start of the currently-scanned literal * in the format string. */ - TclNewObj(tmpObj); /* The buffer used to accumulate the literal + TclNewObj(tmpObj); /* The buffer used to accumulate the literal * being built. */ for (bytes = start ; *bytes ; bytes++) { if (*bytes == '%') { @@ -3354,16 +3407,13 @@ TclCompileFormatCmd( if (*++bytes == '%') { Tcl_AppendToObj(tmpObj, "%", 1); } else { - const char *b = TclGetStringFromObj(tmpObj, &len); - /* * If there is a non-empty literal from the format string, * push it and reset. */ - if (len > 0) { - PushLiteral(envPtr, b, len); - Tcl_DecrRefCount(tmpObj); + if (TclGetString(tmpObj)[0]) { + PUSH_OBJ( tmpObj); TclNewObj(tmpObj); i++; } @@ -3374,7 +3424,7 @@ TclCompileFormatCmd( * directly. */ - CompileWord(envPtr, tokenPtr, interp, j); + PUSH_TOKEN( tokenPtr, j); tokenPtr = TokenAfter(tokenPtr); j++; i++; @@ -3388,12 +3438,11 @@ TclCompileFormatCmd( */ Tcl_AppendToObj(tmpObj, start, bytes - start); - bytes = TclGetStringFromObj(tmpObj, &len); - if (len > 0) { - PushLiteral(envPtr, bytes, len); + if (TclGetString(tmpObj)[0]) { + PUSH_OBJ( tmpObj); i++; } - Tcl_DecrRefCount(tmpObj); + Tcl_BounceRefCount(tmpObj); Tcl_DecrRefCount(formatObj); if (i > 1) { @@ -3401,300 +3450,12 @@ TclCompileFormatCmd( * Do the concatenation, which produces the result. */ - TclEmitInstInt1(INST_STR_CONCAT1, i, envPtr); + OP1( STR_CONCAT1, i); } return TCL_OK; } /* - *---------------------------------------------------------------------- - * - * TclLocalScalarFromToken -- - * - * Get the index into the table of compiled locals that corresponds - * to a local scalar variable name. - * - * Results: - * Returns the non-negative integer index value into the table of - * compiled locals corresponding to a local scalar variable name. - * If the arguments passed in do not identify a local scalar variable - * then return TCL_INDEX_NONE. - * - * Side effects: - * May add an entry into the table of compiled locals. - * - *---------------------------------------------------------------------- - */ - -size_t -TclLocalScalarFromToken( - Tcl_Token *tokenPtr, - CompileEnv *envPtr) -{ - int isScalar, index; - - TclPushVarName(NULL, tokenPtr, envPtr, TCL_NO_ELEMENT, &index, &isScalar); - if (!isScalar) { - index = -1; - } - return index; -} - -size_t -TclLocalScalar( - const char *bytes, - size_t numBytes, - CompileEnv *envPtr) -{ - Tcl_Token token[2] = { - {TCL_TOKEN_SIMPLE_WORD, NULL, 0, 1}, - {TCL_TOKEN_TEXT, NULL, 0, 0} - }; - - token[1].start = bytes; - token[1].size = numBytes; - return TclLocalScalarFromToken(token, envPtr); -} - -/* - *---------------------------------------------------------------------- - * - * TclPushVarName -- - * - * Procedure used in the compiling where pushing a variable name is - * necessary (append, lappend, set). - * - * Results: - * The values written to *localIndexPtr and *isScalarPtr signal to - * the caller what the instructions emitted by this routine will do: - * - * *isScalarPtr (*localIndexPtr < 0) - * 1 1 Push the varname on the stack. (Stack +1) - * 1 0 *localIndexPtr is the index of the compiled - * local for this varname. No instructions - * emitted. (Stack +0) - * 0 1 Push part1 and part2 names of array element - * on the stack. (Stack +2) - * 0 0 *localIndexPtr is the index of the compiled - * local for this array. Element name is pushed - * on the stack. (Stack +1) - * - * Side effects: - * Instructions are added to envPtr. - * - *---------------------------------------------------------------------- - */ - -void -TclPushVarName( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Token *varTokenPtr, /* Points to a variable token. */ - CompileEnv *envPtr, /* Holds resulting instructions. */ - int flags, /* TCL_NO_LARGE_INDEX | TCL_NO_ELEMENT. */ - int *localIndexPtr, /* Must not be NULL. */ - int *isScalarPtr) /* Must not be NULL. */ -{ - const char *p; - const char *last, *name, *elName; - Tcl_Size n; - Tcl_Token *elemTokenPtr = NULL; - size_t nameLen, elNameLen; - int simpleVarName, localIndex; - Tcl_Size elemTokenCount = 0, removedParen = 0; - int allocedTokens = 0; - - /* - * Decide if we can use a frame slot for the var/array name or if we need - * to emit code to compute and push the name at runtime. We use a frame - * slot (entry in the array of local vars) if we are compiling a procedure - * body and if the name is simple text that does not include namespace - * qualifiers. - */ - - simpleVarName = 0; - name = elName = NULL; - nameLen = elNameLen = 0; - localIndex = -1; - - if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - /* - * A simple variable name. Divide it up into "name" and "elName" - * strings. If it is not a local variable, look it up at runtime. - */ - - simpleVarName = 1; - - name = varTokenPtr[1].start; - nameLen = varTokenPtr[1].size; - if (name[nameLen-1] == ')') { - /* - * last char is ')' => potential array reference. - */ - last = &name[nameLen-1]; - - if (*last == ')') { - for (p = name; p < last; p++) { - if (*p == '(') { - elName = p + 1; - elNameLen = last - elName; - nameLen = p - name; - break; - } - } - } - - if (!(flags & TCL_NO_ELEMENT) && elNameLen) { - /* - * An array element, the element name is a simple string: - * assemble the corresponding token. - */ - - elemTokenPtr = (Tcl_Token *)TclStackAlloc(interp, sizeof(Tcl_Token)); - allocedTokens = 1; - elemTokenPtr->type = TCL_TOKEN_TEXT; - elemTokenPtr->start = elName; - elemTokenPtr->size = elNameLen; - elemTokenPtr->numComponents = 0; - elemTokenCount = 1; - } - } - } else if (interp && ((n = varTokenPtr->numComponents) > 1) - && (varTokenPtr[1].type == TCL_TOKEN_TEXT) - && (varTokenPtr[n].type == TCL_TOKEN_TEXT) - && (*(varTokenPtr[n].start + varTokenPtr[n].size - 1) == ')')) { - /* - * Check for parentheses inside first token. - */ - - simpleVarName = 0; - for (p = varTokenPtr[1].start, last = p + varTokenPtr[1].size; - p < last; p++) { - if (*p == '(') { - simpleVarName = 1; - break; - } - } - if (simpleVarName) { - size_t remainingLen; - - /* - * Check the last token: if it is just ')', do not count it. - * Otherwise, remove the ')' and flag so that it is restored at - * the end. - */ - - if (varTokenPtr[n].size == 1) { - n--; - } else { - varTokenPtr[n].size--; - removedParen = n; - } - - name = varTokenPtr[1].start; - nameLen = p - varTokenPtr[1].start; - elName = p + 1; - remainingLen = (varTokenPtr[2].start - p) - 1; - elNameLen = (varTokenPtr[n].start-p) + varTokenPtr[n].size - 1; - - if (!(flags & TCL_NO_ELEMENT)) { - if (remainingLen) { - /* - * Make a first token with the extra characters in the first - * token. - */ - - elemTokenPtr = (Tcl_Token *)TclStackAlloc(interp, n * sizeof(Tcl_Token)); - allocedTokens = 1; - elemTokenPtr->type = TCL_TOKEN_TEXT; - elemTokenPtr->start = elName; - elemTokenPtr->size = remainingLen; - elemTokenPtr->numComponents = 0; - elemTokenCount = n; - - /* - * Copy the remaining tokens. - */ - - memcpy(elemTokenPtr+1, varTokenPtr+2, - (n-1) * sizeof(Tcl_Token)); - } else { - /* - * Use the already available tokens. - */ - - elemTokenPtr = &varTokenPtr[2]; - elemTokenCount = n - 1; - } - } - } - } - - if (simpleVarName) { - /* - * See whether name has any namespace separators (::'s). - */ - - int hasNsQualifiers = 0; - - for (p = name, last = p + nameLen-1; p < last; p++) { - if ((p[0] == ':') && (p[1] == ':')) { - hasNsQualifiers = 1; - break; - } - } - - /* - * Look up the var name's index in the array of local vars in the proc - * frame. If retrieving the var's value and it doesn't already exist, - * push its name and look it up at runtime. - */ - - if (!hasNsQualifiers) { - localIndex = TclFindCompiledLocal(name, nameLen, 1, envPtr); - if ((flags & TCL_NO_LARGE_INDEX) && (localIndex > 255)) { - /* - * We'll push the name. - */ - - localIndex = -1; - } - } - if (interp && localIndex < 0) { - PushLiteral(envPtr, name, nameLen); - } - - /* - * Compile the element script, if any, and only if not inhibited. [Bug - * 3600328] - */ - - if (elName != NULL && !(flags & TCL_NO_ELEMENT)) { - if (elNameLen) { - TclCompileTokens(interp, elemTokenPtr, elemTokenCount, - envPtr); - } else { - PushStringLiteral(envPtr, ""); - } - } - } else if (interp) { - /* - * The var name isn't simple: compile and push it. - */ - - CompileTokens(envPtr, varTokenPtr, interp); - } - - if (removedParen) { - varTokenPtr[removedParen].size++; - } - if (allocedTokens) { - TclStackFree(interp, elemTokenPtr); - } - *localIndexPtr = localIndex; - *isScalarPtr = (elName == NULL); -} - -/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index c373018..c473f88 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -25,7 +25,7 @@ static void CompileReturnInternal(CompileEnv *envPtr, unsigned char op, int code, int level, Tcl_Obj *returnOpts); -static int IndexTailVarIfKnown(Tcl_Interp *interp, +static Tcl_LVTIndex IndexTailVarIfKnown(Tcl_Interp *interp, Tcl_Token *varTokenPtr, CompileEnv *envPtr); /* @@ -58,7 +58,7 @@ TclGetIndexFromToken( TclNewObj(tmpObj); if (TclWordKnownAtCompileTime(tokenPtr, tmpObj)) { - result = TclIndexEncode(NULL, tmpObj, before, after, indexPtr); + result = TclIndexEncode(NULL, tmpObj, (int)before, (int)after, indexPtr); } Tcl_DecrRefCount(tmpObj); return result; @@ -92,11 +92,10 @@ TclCompileGlobalCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr; - int localIndex, numWords, i; + Tcl_LVTIndex localIndex; + Tcl_Size i, numWords = parsePtr->numWords; - /* TODO: Consider support for compiling expanded args. */ - numWords = parsePtr->numWords; - if (numWords < 2) { + if (numWords < 2 || numWords > UINT_MAX) { return TCL_ERROR; } @@ -104,7 +103,7 @@ TclCompileGlobalCmd( * 'global' has no effect outside of proc bodies; handle that at runtime */ - if (envPtr->procPtr == NULL) { + if (!EnvIsProc(envPtr)) { return TCL_ERROR; } @@ -112,7 +111,7 @@ TclCompileGlobalCmd( * Push the namespace */ - PushStringLiteral(envPtr, "::"); + PUSH( "::"); /* * Loop over the variables. @@ -122,7 +121,7 @@ TclCompileGlobalCmd( for (i=1; i<numWords; varTokenPtr = TokenAfter(varTokenPtr),i++) { localIndex = IndexTailVarIfKnown(interp, varTokenPtr, envPtr); - if (localIndex < 0) { + if (localIndex < 0 || localIndex > INT_MAX) { return TCL_ERROR; } @@ -132,16 +131,16 @@ TclCompileGlobalCmd( * apply here. Push known value instead. */ - CompileWord(envPtr, varTokenPtr, interp, i); - TclEmitInstInt4( INST_NSUPVAR, localIndex, envPtr); + PUSH_TOKEN( varTokenPtr, i); + OP4( NSUPVAR, localIndex); } /* * Pop the namespace, and set the result to empty */ - TclEmitOpcode( INST_POP, envPtr); - PushStringLiteral(envPtr, ""); + OP( POP); + PUSH( ""); return TCL_OK; } @@ -180,10 +179,9 @@ TclCompileIfCmd( * to the end of the "if" when that PC is * determined. */ Tcl_Token *tokenPtr, *testTokenPtr; - int jumpIndex = 0; /* Avoid compiler warning. */ - size_t numBytes, j; - int jumpFalseDist, numWords, wordIdx, code; - const char *word; + Tcl_Size jumpIndex = 0; /* Avoid compiler warning. */ + Tcl_Size j, numWords, wordIdx; + int code; int realCond = 1; /* Set to 0 for static conditions: * "if 0 {..}" */ int boolVal; /* Value of static condition. */ @@ -191,12 +189,14 @@ TclCompileIfCmd( /* * Only compile the "if" command if all arguments are simple words, in - * order to insure correct substitution [Bug 219166] + * order to ensure correct substitution [Bug 219166] */ tokenPtr = parsePtr->tokenPtr; - wordIdx = 0; numWords = parsePtr->numWords; + if (numWords > UINT_MAX) { + return TCL_ERROR; + } for (wordIdx = 0; wordIdx < numWords; wordIdx++) { if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { @@ -221,10 +221,8 @@ TclCompileIfCmd( * Stop looping if the token isn't "if" or "elseif". */ - word = tokenPtr[1].start; - numBytes = tokenPtr[1].size; if ((tokenPtr == parsePtr->tokenPtr) - || ((numBytes == 6) && (strncmp(word, "elseif", 6) == 0))) { + || IS_TOKEN_LITERALLY(tokenPtr, "elseif")) { tokenPtr = TokenAfter(tokenPtr); wordIdx++; } else { @@ -247,12 +245,9 @@ TclCompileIfCmd( * Find out if the condition is a constant. */ - Tcl_Obj *boolObj = Tcl_NewStringObj(testTokenPtr[1].start, - testTokenPtr[1].size); - - Tcl_IncrRefCount(boolObj); + Tcl_Obj *boolObj = TokenToObj(testTokenPtr); code = Tcl_GetBooleanFromObj(NULL, boolObj, &boolVal); - TclDecrRefCount(boolObj); + Tcl_BounceRefCount(boolObj); if (code == TCL_OK) { /* * A static condition. @@ -263,14 +258,12 @@ TclCompileIfCmd( compileScripts = 0; } } else { - SetLineInformation(wordIdx); Tcl_ResetResult(interp); - TclCompileExprWords(interp, testTokenPtr, 1, envPtr); + PUSH_EXPR_TOKEN(testTokenPtr, wordIdx); if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) { TclExpandJumpFixupArray(&jumpFalseFixupArray); } - jumpIndex = jumpFalseFixupArray.next; - jumpFalseFixupArray.next++; + jumpIndex = jumpFalseFixupArray.next++; TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, jumpFalseFixupArray.fixup + jumpIndex); } @@ -287,16 +280,12 @@ TclCompileIfCmd( code = TCL_ERROR; goto done; } - if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - word = tokenPtr[1].start; - numBytes = tokenPtr[1].size; - if ((numBytes == 4) && (strncmp(word, "then", 4) == 0)) { - tokenPtr = TokenAfter(tokenPtr); - wordIdx++; - if (wordIdx >= numWords) { - code = TCL_ERROR; - goto done; - } + if (IS_TOKEN_LITERALLY(tokenPtr, "then")) { + tokenPtr = TokenAfter(tokenPtr); + wordIdx++; + if (wordIdx >= numWords) { + code = TCL_ERROR; + goto done; } } @@ -305,7 +294,7 @@ TclCompileIfCmd( */ if (compileScripts) { - BODY(tokenPtr, wordIdx); + BODY( tokenPtr, wordIdx); } if (realCond) { @@ -322,23 +311,12 @@ TclCompileIfCmd( jumpEndFixupArray.fixup + jumpIndex); /* - * Fix the target of the jumpFalse after the test. Generate a 4 - * byte jump if the distance is > 120 bytes. This is conservative, - * and ensures that we won't have to replace this jump if we later - * also need to replace the proceeding jump to the end of the "if" - * with a 4 byte jump. + * Fix the target of the jumpFalse after the test. */ - TclAdjustStackDepth(-1, envPtr); - if (TclFixupForwardJumpToHere(envPtr, - jumpFalseFixupArray.fixup + jumpIndex, 120)) { - /* - * Adjust the code offset for the proceeding jump to the end - * of the "if" command. - */ - - jumpEndFixupArray.fixup[jumpIndex].codeOffset += 3; - } + STKDELTA(-1); + TclFixupForwardJumpToHere(envPtr, + jumpFalseFixupArray.fixup + jumpIndex); } else if (boolVal) { /* * We were processing an "if 1 {...}"; stop compiling scripts. @@ -369,9 +347,7 @@ TclCompileIfCmd( * There is an else clause. Skip over the optional "else" word. */ - word = tokenPtr[1].start; - numBytes = tokenPtr[1].size; - if ((numBytes == 4) && (strncmp(word, "else", 4) == 0)) { + if (IS_TOKEN_LITERALLY(tokenPtr, "else")) { tokenPtr = TokenAfter(tokenPtr); wordIdx++; if (wordIdx >= numWords) { @@ -385,7 +361,7 @@ TclCompileIfCmd( * Compile the else command body. */ - BODY(tokenPtr, wordIdx); + BODY( tokenPtr, wordIdx); } /* @@ -403,7 +379,7 @@ TclCompileIfCmd( */ if (compileScripts) { - PushStringLiteral(envPtr, ""); + PUSH( ""); } } @@ -413,29 +389,8 @@ TclCompileIfCmd( for (j = jumpEndFixupArray.next; j > 0; j--) { jumpIndex = (j - 1); /* i.e. process the closest jump first. */ - if (TclFixupForwardJumpToHere(envPtr, - jumpEndFixupArray.fixup + jumpIndex, 127)) { - /* - * Adjust the immediately preceding "ifFalse" jump. We moved it's - * target (just after this jump) down three bytes. - */ - - unsigned char *ifFalsePc = envPtr->codeStart - + jumpFalseFixupArray.fixup[jumpIndex].codeOffset; - unsigned char opCode = *ifFalsePc; - - if (opCode == INST_JUMP_FALSE1) { - jumpFalseDist = TclGetInt1AtPtr(ifFalsePc + 1); - jumpFalseDist += 3; - TclStoreInt1AtPtr(jumpFalseDist, (ifFalsePc + 1)); - } else if (opCode == INST_JUMP_FALSE4) { - jumpFalseDist = TclGetInt4AtPtr(ifFalsePc + 1); - jumpFalseDist += 3; - TclStoreInt4AtPtr(jumpFalseDist, (ifFalsePc + 1)); - } else { - Tcl_Panic("TclCompileIfCmd: unexpected opcode \"%d\" updating ifFalse jump", opCode); - } - } + TclFixupForwardJumpToHere(envPtr, + jumpEndFixupArray.fixup + jumpIndex); } /* @@ -476,7 +431,8 @@ TclCompileIncrCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr, *incrTokenPtr; - int isScalar, localIndex, haveImmValue; + int isScalar, haveImmValue; + Tcl_LVTIndex localIndex; Tcl_WideInt immValue; if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) { @@ -484,9 +440,7 @@ TclCompileIncrCmd( } varTokenPtr = TokenAfter(parsePtr->tokenPtr); - - PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_LARGE_INDEX, - &localIndex, &isScalar, 1); + PushVarNameWord(varTokenPtr, 0, &localIndex, &isScalar, 1); /* * If an increment is given, push it, but see first if it's a small @@ -496,23 +450,17 @@ TclCompileIncrCmd( haveImmValue = 0; immValue = 1; if (parsePtr->numWords == 3) { + Tcl_Obj *intObj; incrTokenPtr = TokenAfter(varTokenPtr); - if (incrTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - const char *word = incrTokenPtr[1].start; - size_t numBytes = incrTokenPtr[1].size; - int code; - Tcl_Obj *intObj = Tcl_NewStringObj(word, numBytes); - - Tcl_IncrRefCount(intObj); - code = TclGetWideIntFromObj(NULL, intObj, &immValue); + TclNewObj(intObj); + if (TclWordKnownAtCompileTime(incrTokenPtr, intObj)) { + int code = TclGetWideIntFromObj(NULL, intObj, &immValue); if ((code == TCL_OK) && (-127 <= immValue) && (immValue <= 127)) { haveImmValue = 1; } - TclDecrRefCount(intObj); - if (!haveImmValue) { - PushLiteral(envPtr, word, numBytes); - } - } else { + } + Tcl_BounceRefCount(intObj); + if (!haveImmValue) { SetLineInformation(2); CompileTokens(envPtr, incrTokenPtr, interp); } @@ -524,34 +472,32 @@ TclCompileIncrCmd( * Emit the instruction to increment the variable. */ - if (isScalar) { /* Simple scalar variable. */ + if (isScalar) { /* Simple scalar variable. */ if (localIndex >= 0) { if (haveImmValue) { - TclEmitInstInt1(INST_INCR_SCALAR1_IMM, localIndex, envPtr); - TclEmitInt1(immValue, envPtr); + OP41( INCR_SCALAR_IMM, localIndex, immValue); } else { - TclEmitInstInt1(INST_INCR_SCALAR1, localIndex, envPtr); + OP4( INCR_SCALAR, localIndex); } } else { if (haveImmValue) { - TclEmitInstInt1(INST_INCR_STK_IMM, immValue, envPtr); + OP1( INCR_STK_IMM, immValue); } else { - TclEmitOpcode( INST_INCR_STK, envPtr); + OP( INCR_STK); } } } else { /* Simple array variable. */ if (localIndex >= 0) { if (haveImmValue) { - TclEmitInstInt1(INST_INCR_ARRAY1_IMM, localIndex, envPtr); - TclEmitInt1(immValue, envPtr); + OP41( INCR_ARRAY_IMM, localIndex, immValue); } else { - TclEmitInstInt1(INST_INCR_ARRAY1, localIndex, envPtr); + OP4( INCR_ARRAY, localIndex); } } else { if (haveImmValue) { - TclEmitInstInt1(INST_INCR_ARRAY_STK_IMM, immValue, envPtr); + OP1( INCR_ARRAY_STK_IMM, immValue); } else { - TclEmitOpcode( INST_INCR_ARRAY_STK, envPtr); + OP( INCR_ARRAY_STK); } } } @@ -590,6 +536,7 @@ TclCompileInfoCommandsCmd( Tcl_Token *tokenPtr; Tcl_Obj *objPtr; const char *bytes; + Tcl_BytecodeLabel isList; /* * We require one compile-time known argument for the case we can compile. @@ -625,12 +572,13 @@ TclCompileInfoCommandsCmd( */ /* TODO: Just push the known value */ - CompileWord(envPtr, tokenPtr, interp, 1); - TclEmitOpcode( INST_RESOLVE_COMMAND, envPtr); - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_STR_LEN, envPtr); - TclEmitInstInt1( INST_JUMP_FALSE1, 7, envPtr); - TclEmitInstInt4( INST_LIST, 1, envPtr); + PUSH_TOKEN( tokenPtr, 1); + OP( RESOLVE_COMMAND); + OP( DUP); + OP( STR_LEN); + FWDJUMP( JUMP_FALSE, isList); + OP4( LIST, 1); + FWDLABEL( isList); return TCL_OK; notCompilable: @@ -658,7 +606,7 @@ TclCompileInfoCoroutineCmd( * Not much to do; we compile to a single instruction... */ - TclEmitOpcode( INST_COROUTINE_NAME, envPtr); + OP( COROUTINE_NAME); return TCL_OK; } @@ -672,7 +620,8 @@ TclCompileInfoExistsCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - int isScalar, localIndex; + int isScalar; + Tcl_LVTIndex localIndex; if (parsePtr->numWords != 2) { return TCL_ERROR; @@ -687,7 +636,7 @@ TclCompileInfoExistsCmd( */ tokenPtr = TokenAfter(parsePtr->tokenPtr); - PushVarNameWord(interp, tokenPtr, envPtr, 0, &localIndex, &isScalar, 1); + PushVarNameWord(tokenPtr, 0, &localIndex, &isScalar, 1); /* * Emit instruction to check the variable for existence. @@ -695,15 +644,15 @@ TclCompileInfoExistsCmd( if (isScalar) { if (localIndex < 0) { - TclEmitOpcode( INST_EXIST_STK, envPtr); + OP( EXIST_STK); } else { - TclEmitInstInt4( INST_EXIST_SCALAR, localIndex, envPtr); + OP4( EXIST_SCALAR, localIndex); } } else { if (localIndex < 0) { - TclEmitOpcode( INST_EXIST_ARRAY_STK, envPtr); + OP( EXIST_ARRAY_STK); } else { - TclEmitInstInt4( INST_EXIST_ARRAY, localIndex, envPtr); + OP4( EXIST_ARRAY, localIndex); } } @@ -727,7 +676,7 @@ TclCompileInfoLevelCmd( * Not much to do; we compile to a single instruction... */ - TclEmitOpcode( INST_INFO_LEVEL_NUM, envPtr); + OP( INFO_LEVEL_NUM); } else if (parsePtr->numWords != 2) { return TCL_ERROR; } else { @@ -738,8 +687,8 @@ TclCompileInfoLevelCmd( * list of arguments. */ - CompileWord(envPtr, TokenAfter(parsePtr->tokenPtr), interp, 1); - TclEmitOpcode( INST_INFO_LEVEL_ARGS, envPtr); + PUSH_TOKEN( TokenAfter(parsePtr->tokenPtr), 1); + OP( INFO_LEVEL_ARGS); } return TCL_OK; } @@ -758,8 +707,27 @@ TclCompileInfoObjectClassCmd( if (parsePtr->numWords != 2) { return TCL_ERROR; } - CompileWord(envPtr, tokenPtr, interp, 1); - TclEmitOpcode( INST_TCLOO_CLASS, envPtr); + PUSH_TOKEN( tokenPtr, 1); + OP( TCLOO_CLASS); + return TCL_OK; +} + +int +TclCompileInfoObjectCreationIdCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + TCL_UNUSED(Command *), + CompileEnv *envPtr) +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); + + if (parsePtr->numWords != 2) { + return TCL_ERROR; + } + PUSH_TOKEN( tokenPtr, 1); + OP( TCLOO_ID); return TCL_OK; } @@ -783,8 +751,7 @@ TclCompileInfoObjectIsACmd( if (parsePtr->numWords != 3) { return TCL_ERROR; } - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size < 1 - || strncmp(tokenPtr[1].start, "object", tokenPtr[1].size)) { + if (!IS_TOKEN_PREFIX(tokenPtr, 2, "object")) { return TCL_ERROR; } tokenPtr = TokenAfter(tokenPtr); @@ -793,8 +760,8 @@ TclCompileInfoObjectIsACmd( * Issue the code. */ - CompileWord(envPtr, tokenPtr, interp, 2); - TclEmitOpcode( INST_TCLOO_IS_OBJECT, envPtr); + PUSH_TOKEN( tokenPtr, 2); + OP( TCLOO_IS_OBJECT); return TCL_OK; } @@ -812,8 +779,8 @@ TclCompileInfoObjectNamespaceCmd( if (parsePtr->numWords != 2) { return TCL_ERROR; } - CompileWord(envPtr, tokenPtr, interp, 1); - TclEmitOpcode( INST_TCLOO_NS, envPtr); + PUSH_TOKEN( tokenPtr, 1); + OP( TCLOO_NS); return TCL_OK; } @@ -845,18 +812,14 @@ TclCompileLappendCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr, *valueTokenPtr; - int isScalar, localIndex, numWords, i; + Tcl_Size numWords = parsePtr->numWords, i; + int isScalar; + Tcl_LVTIndex localIndex; - /* TODO: Consider support for compiling expanded args. */ - numWords = parsePtr->numWords; - if (numWords < 3) { + if (numWords < 2 || numWords > UINT_MAX) { return TCL_ERROR; } - if (numWords != 3 || envPtr->procPtr == NULL) { - goto lappendMultiple; - } - /* * Decide if we can use a frame slot for the var/array name or if we * need to emit code to compute and push the name at runtime. We use a @@ -866,67 +829,137 @@ TclCompileLappendCmd( */ varTokenPtr = TokenAfter(parsePtr->tokenPtr); + if (varTokenPtr->type == TCL_TOKEN_EXPAND_WORD) { + /* Cannot compile if we don't know the variable properly! */ + return TCL_ERROR; + } + PushVarNameWord(varTokenPtr, 0, &localIndex, &isScalar, 1); - PushVarNameWord(interp, varTokenPtr, envPtr, 0, - &localIndex, &isScalar, 1); + if (numWords != 3) { + goto lappendMultiple; + } /* - * If we are doing an assignment, push the new value. In the no values - * case, create an empty object. + * We are doing an assignment, so push the new value. */ - if (numWords > 2) { - valueTokenPtr = TokenAfter(varTokenPtr); - - CompileWord(envPtr, valueTokenPtr, interp, 2); + valueTokenPtr = TokenAfter(varTokenPtr); + PUSH_TOKEN( valueTokenPtr, 2); + if (valueTokenPtr->type == TCL_TOKEN_EXPAND_WORD) { + /* + * Special case: appending a single expanded list. MUST force a drop of + * the string representation at this point because INST_LAPPEND_LIST* + * might use it directly. + */ + OP44( LIST_RANGE_IMM, 0, TCL_INDEX_END); + goto lappendList; + } else if (!EnvHasLVT(envPtr)) { + /* + * The weird cluster of bugs around INST_LAPPEND_STK without a LVT + * ought to be sorted out. INST_LAPPEND_LIST_STK does the right thing. + */ + OP4( LIST, 1); + goto lappendList; } /* - * Emit instructions to set/get the variable. - */ - - /* + * Emit instructions to append the item to the variable. + * * The *_STK opcodes should be refactored to make better use of existing * LOAD/STORE instructions. */ if (isScalar) { if (localIndex < 0) { - TclEmitOpcode( INST_LAPPEND_STK, envPtr); + OP( LAPPEND_STK); } else { - Emit14Inst( INST_LAPPEND_SCALAR, localIndex, envPtr); + OP4( LAPPEND_SCALAR, localIndex); } } else { if (localIndex < 0) { - TclEmitOpcode( INST_LAPPEND_ARRAY_STK, envPtr); + OP( LAPPEND_ARRAY_STK); } else { - Emit14Inst( INST_LAPPEND_ARRAY, localIndex, envPtr); + OP4( LAPPEND_ARRAY, localIndex); } } - return TCL_OK; + /* + * In the cases where there's not a single value to append to the list in + * the variable, we use a different strategy. This is to turn the arguments + * into a list and then append that list's elements. The downside is that + * this allocates a temporary working list, but at least it simplifies the + * code issuing a lot. + */ + lappendMultiple: - varTokenPtr = TokenAfter(parsePtr->tokenPtr); - PushVarNameWord(interp, varTokenPtr, envPtr, 0, - &localIndex, &isScalar, 1); - valueTokenPtr = TokenAfter(varTokenPtr); - for (i = 2 ; i < numWords ; i++) { - CompileWord(envPtr, valueTokenPtr, interp, i); - valueTokenPtr = TokenAfter(valueTokenPtr); + + /* + * Concatenate all our remaining arguments into a list. This is slightly + * complicated because we also handle expansion. + */ + + if (numWords == 2) { + PUSH( ""); + } else { + Tcl_Size build = 0; + int concat = 0; + + valueTokenPtr = TokenAfter(varTokenPtr); + for (i = 2; i < numWords; i++) { + if (valueTokenPtr->type == TCL_TOKEN_EXPAND_WORD && build > 0) { + OP4( LIST, build); + if (concat) { + OP( LIST_CONCAT); + } + build = 0; + concat = 1; + } + PUSH_TOKEN( valueTokenPtr, i); + if (valueTokenPtr->type == TCL_TOKEN_EXPAND_WORD) { + if (concat) { + OP( LIST_CONCAT); + } else { + concat = 1; + } + } else { + build++; + } + if (build > LIST_CONCAT_THRESHOLD) { + OP4( LIST, build); + if (concat) { + OP( LIST_CONCAT); + } + build = 0; + concat = 1; + } + valueTokenPtr = TokenAfter(valueTokenPtr); + } + if (build > 0) { + OP4( LIST, build); + if (concat) { + OP( LIST_CONCAT); + } + } } - TclEmitInstInt4( INST_LIST, numWords - 2, envPtr); + + /* + * Append the items of the list to the variable. The implementation of + * these opcodes handles all the special cases that [lappend] knows about. + */ + + lappendList: if (isScalar) { if (localIndex < 0) { - TclEmitOpcode( INST_LAPPEND_LIST_STK, envPtr); + OP( LAPPEND_LIST_STK); } else { - TclEmitInstInt4(INST_LAPPEND_LIST, localIndex, envPtr); + OP4( LAPPEND_LIST, localIndex); } } else { if (localIndex < 0) { - TclEmitOpcode( INST_LAPPEND_LIST_ARRAY_STK, envPtr); + OP( LAPPEND_LIST_ARRAY_STK); } else { - TclEmitInstInt4(INST_LAPPEND_LIST_ARRAY, localIndex,envPtr); + OP4( LAPPEND_LIST_ARRAY, localIndex); } } return TCL_OK; @@ -960,15 +993,16 @@ TclCompileLassignCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - int isScalar, localIndex, numWords, idx; - - numWords = parsePtr->numWords; + int isScalar; + Tcl_Size numWords = parsePtr->numWords, idx; + Tcl_LVTIndex localIndex; + /* TODO: Consider support for compiling expanded args. */ /* * Check for command syntax error, but we'll punt that to runtime. */ - if (numWords < 3) { + if (numWords < 3 || numWords > UINT_MAX) { return TCL_ERROR; } @@ -977,21 +1011,19 @@ TclCompileLassignCmd( */ tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); + PUSH_TOKEN( tokenPtr, 1); /* * Generate code to assign values from the list to variables. */ for (idx=0 ; idx<numWords-2 ; idx++) { - tokenPtr = TokenAfter(tokenPtr); - /* * Generate the next variable name. */ - PushVarNameWord(interp, tokenPtr, envPtr, 0, &localIndex, - &isScalar, idx + 2); + tokenPtr = TokenAfter(tokenPtr); + PushVarNameWord(tokenPtr, 0, &localIndex, &isScalar, idx + 2); /* * Emit instructions to get the idx'th item out of the list value on @@ -1000,27 +1032,27 @@ TclCompileLassignCmd( if (isScalar) { if (localIndex >= 0) { - TclEmitOpcode( INST_DUP, envPtr); - TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); - Emit14Inst( INST_STORE_SCALAR, localIndex, envPtr); - TclEmitOpcode( INST_POP, envPtr); + OP( DUP); + OP4( LIST_INDEX_IMM, idx); + OP4( STORE_SCALAR, localIndex); + OP( POP); } else { - TclEmitInstInt4(INST_OVER, 1, envPtr); - TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); - TclEmitOpcode( INST_STORE_STK, envPtr); - TclEmitOpcode( INST_POP, envPtr); + OP4( OVER, 1); + OP4( LIST_INDEX_IMM, idx); + OP( STORE_STK); + OP( POP); } } else { if (localIndex >= 0) { - TclEmitInstInt4(INST_OVER, 1, envPtr); - TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); - Emit14Inst( INST_STORE_ARRAY, localIndex, envPtr); - TclEmitOpcode( INST_POP, envPtr); + OP4( OVER, 1); + OP4( LIST_INDEX_IMM, idx); + OP4( STORE_ARRAY, localIndex); + OP( POP); } else { - TclEmitInstInt4(INST_OVER, 2, envPtr); - TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); - TclEmitOpcode( INST_STORE_ARRAY_STK, envPtr); - TclEmitOpcode( INST_POP, envPtr); + OP4( OVER, 2); + OP4( LIST_INDEX_IMM, idx); + OP( STORE_ARRAY_STK); + OP( POP); } } } @@ -1029,8 +1061,7 @@ TclCompileLassignCmd( * Generate code to leave the rest of the list on the stack. */ - TclEmitInstInt4( INST_LIST_RANGE_IMM, idx, envPtr); - TclEmitInt4( (int)TCL_INDEX_END, envPtr); + OP44( LIST_RANGE_IMM, idx, TCL_INDEX_END); return TCL_OK; } @@ -1063,14 +1094,15 @@ TclCompileLindexCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *idxTokenPtr, *valTokenPtr; - int i, idx, numWords = parsePtr->numWords; + Tcl_Size i, numWords = parsePtr->numWords; + int idx; /* * Quit if not enough args. */ /* TODO: Consider support for compiling expanded args. */ - if (numWords <= 1) { + if (numWords <= 1 || numWords > UINT_MAX) { return TCL_ERROR; } @@ -1090,8 +1122,8 @@ TclCompileLindexCmd( * same result as indexing after a list. */ - CompileWord(envPtr, valTokenPtr, interp, 1); - TclEmitInstInt4( INST_LIST_INDEX_IMM, idx, envPtr); + PUSH_TOKEN( valTokenPtr, 1); + OP4( LIST_INDEX_IMM, idx); return TCL_OK; } @@ -1107,7 +1139,7 @@ TclCompileLindexCmd( emitComplexLindex: for (i=1 ; i<numWords ; i++) { - CompileWord(envPtr, valTokenPtr, interp, i); + PUSH_TOKEN( valTokenPtr, i); valTokenPtr = TokenAfter(valTokenPtr); } @@ -1117,9 +1149,9 @@ TclCompileLindexCmd( */ if (numWords == 3) { - TclEmitOpcode( INST_LIST_INDEX, envPtr); + OP( LIST_INDEX); } else { - TclEmitInstInt4( INST_LIST_INDEX_MULTI, numWords-1, envPtr); + OP4( LIST_INDEX_MULTI, numWords - 1); } return TCL_OK; @@ -1131,6 +1163,7 @@ TclCompileLindexCmd( * TclCompileListCmd -- * * Procedure called to compile the "list" command. + * Handles argument expansion directly. * * Results: * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer @@ -1153,15 +1186,19 @@ TclCompileListCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *valueTokenPtr; - int i, numWords, concat, build; + Tcl_Size i, build, numWords = parsePtr->numWords; + int concat; Tcl_Obj *listObj, *objPtr; - if (parsePtr->numWords == 1) { + if (numWords > UINT_MAX) { + return TCL_ERROR; + } + if (numWords == 1) { /* * [list] without arguments just pushes an empty object. */ - PushStringLiteral(envPtr, ""); + PUSH( ""); return TCL_OK; } @@ -1170,7 +1207,6 @@ TclCompileListCmd( * implement with a simple push. */ - numWords = parsePtr->numWords; valueTokenPtr = TokenAfter(parsePtr->tokenPtr); TclNewObj(listObj); for (i = 1; i < numWords && listObj != NULL; i++) { @@ -1185,7 +1221,7 @@ TclCompileListCmd( valueTokenPtr = TokenAfter(valueTokenPtr); } if (listObj != NULL) { - TclEmitPush(TclAddLiteralObj(envPtr, listObj, NULL), envPtr); + PUSH_OBJ( listObj); return TCL_OK; } @@ -1193,34 +1229,40 @@ TclCompileListCmd( * Push the all values onto the stack. */ - numWords = parsePtr->numWords; valueTokenPtr = TokenAfter(parsePtr->tokenPtr); - concat = build = 0; - for (i = 1; i < numWords; i++) { + for (concat = 0, build = 0, i = 1; i < numWords; i++) { if (valueTokenPtr->type == TCL_TOKEN_EXPAND_WORD && build > 0) { - TclEmitInstInt4( INST_LIST, build, envPtr); + OP4( LIST, build); if (concat) { - TclEmitOpcode( INST_LIST_CONCAT, envPtr); + OP( LIST_CONCAT); } build = 0; concat = 1; } - CompileWord(envPtr, valueTokenPtr, interp, i); + PUSH_TOKEN( valueTokenPtr, i); if (valueTokenPtr->type == TCL_TOKEN_EXPAND_WORD) { if (concat) { - TclEmitOpcode( INST_LIST_CONCAT, envPtr); + OP( LIST_CONCAT); } else { concat = 1; } } else { build++; } + if (build > LIST_CONCAT_THRESHOLD) { + OP4( LIST, build); + if (concat) { + OP( LIST_CONCAT); + } + build = 0; + concat = 1; + } valueTokenPtr = TokenAfter(valueTokenPtr); } if (build > 0) { - TclEmitInstInt4( INST_LIST, build, envPtr); + OP4( LIST, build); if (concat) { - TclEmitOpcode( INST_LIST_CONCAT, envPtr); + OP( LIST_CONCAT); } } @@ -1232,8 +1274,7 @@ TclCompileListCmd( */ if (concat && numWords == 2) { - TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); - TclEmitInt4( (int)TCL_INDEX_END, envPtr); + OP44( LIST_RANGE_IMM, 0, TCL_INDEX_END); } return TCL_OK; } @@ -1272,8 +1313,8 @@ TclCompileLlengthCmd( } varTokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, varTokenPtr, interp, 1); - TclEmitOpcode( INST_LIST_LENGTH, envPtr); + PUSH_TOKEN( varTokenPtr, 1); + OP( LIST_LENGTH); return TCL_OK; } @@ -1331,9 +1372,8 @@ TclCompileLrangeCmd( * is worth trying to do that given current knowledge. */ - CompileWord(envPtr, listTokenPtr, interp, 1); - TclEmitInstInt4( INST_LIST_RANGE_IMM, idx1, envPtr); - TclEmitInt4( idx2, envPtr); + PUSH_TOKEN( listTokenPtr, 1); + OP44( LIST_RANGE_IMM, idx1, idx2); return TCL_OK; } @@ -1357,35 +1397,36 @@ TclCompileLinsertCmd( CompileEnv *envPtr) /* Holds the resulting instructions. */ { DefineLineInformation; /* TIP #280 */ - Tcl_Token *tokenPtr; - int i; + Tcl_Token *listToken, *indexToken, *tokenPtr; + Tcl_Size i, numWords = parsePtr->numWords; + /* TODO: Consider support for compiling expanded args. */ - if ((int)parsePtr->numWords < 3) { + if (numWords < 3 || numWords > UINT_MAX) { return TCL_ERROR; } /* Push list, insertion index onto the stack */ - tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 2); + listToken = TokenAfter(parsePtr->tokenPtr); + indexToken = TokenAfter(listToken); + + PUSH_TOKEN( listToken, 1); + PUSH_TOKEN( indexToken, 2); /* Push new elements to be inserted */ - for (i=3 ; i<(int)parsePtr->numWords ; i++) { - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, i); + tokenPtr = TokenAfter(indexToken); + for (i=3 ; i<numWords ; i++,tokenPtr=TokenAfter(tokenPtr)) { + PUSH_TOKEN( tokenPtr, i); } - /* First operand is count of arguments */ - TclEmitInstInt4(INST_LREPLACE4, parsePtr->numWords - 1, envPtr); /* + * First operand is count of arguments. * Second operand is bitmask - * TCL_LREPLACE4_END_IS_LAST - end refers to last element - * TCL_LREPLACE4_SINGLE_INDEX - second index is not present + * TCL_LREPLACE_END_IS_LAST - end refers to last element + * TCL_LREPLACE_SINGLE_INDEX - second index is not present * indicating this is a pure insert */ - TclEmitInt1(TCL_LREPLACE4_SINGLE_INDEX, envPtr); - + OP41( LREPLACE, numWords - 1, + TCL_LREPLACE_SINGLE_INDEX); return TCL_OK; } @@ -1409,36 +1450,458 @@ TclCompileLreplaceCmd( CompileEnv *envPtr) /* Holds the resulting instructions. */ { DefineLineInformation; /* TIP #280 */ - Tcl_Token *tokenPtr; - int i; + Tcl_Token *listToken, *firstToken, *lastToken, *tokenPtr; + Tcl_Size i, numWords = parsePtr->numWords; + /* TODO: Consider support for compiling expanded args. */ - if (parsePtr->numWords < 4) { + if (numWords < 4 || numWords > UINT_MAX) { return TCL_ERROR; } /* Push list, first, last onto the stack */ - tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 2); - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 3); + listToken = TokenAfter(parsePtr->tokenPtr); + firstToken = TokenAfter(listToken); + lastToken = TokenAfter(firstToken); + + PUSH_TOKEN( listToken, 1); + PUSH_TOKEN( firstToken, 2); + PUSH_TOKEN( lastToken, 3); /* Push new elements to be inserted */ - for (i=4 ; i< (int)parsePtr->numWords ; i++) { - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, i); + tokenPtr = TokenAfter(lastToken); + for (i=4; i<numWords; i++,tokenPtr=TokenAfter(tokenPtr)) { + PUSH_TOKEN( tokenPtr, i); } - /* First operand is count of arguments */ - TclEmitInstInt4(INST_LREPLACE4, parsePtr->numWords - 1, envPtr); /* + * First operand is count of arguments. * Second operand is bitmask - * TCL_LREPLACE4_END_IS_LAST - end refers to last element + * TCL_LREPLACE_END_IS_LAST - end refers to last element */ - TclEmitInt1(TCL_LREPLACE4_END_IS_LAST, envPtr); + OP41( LREPLACE, numWords - 1, + TCL_LREPLACE_END_IS_LAST); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileLeditCmd -- + * + * How to compile the "ledit" command. Generally very similar in concept + * to TclCompileLreplaceCmd, except for the variable handling. + * + *---------------------------------------------------------------------- + */ +int +TclCompileLeditCmd( + Tcl_Interp *interp, /* Tcl interpreter for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the + * command. */ + TCL_UNUSED(Command *), + CompileEnv *envPtr) /* Holds the resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Size numWords = parsePtr->numWords, i; + /* TODO: Consider support for compiling expanded args. */ + if (numWords < 4) { + return TCL_ERROR; + } + Tcl_Token *varTokenPtr = TokenAfter(parsePtr->tokenPtr); + + /* + * Parse/push the variable name. Pushes 0, 1 or 2 words. + */ + + Tcl_LVTIndex varIdx; + int isScalar; + PushVarNameWord(varTokenPtr, 0, &varIdx, &isScalar, 1); + // Stack: varWords... + + /* + * Push all remaining words; there's definitely at least two. + */ + + Tcl_Token *tokenPtr = TokenAfter(varTokenPtr); + for (i=2; i<numWords; i++, tokenPtr=TokenAfter(tokenPtr)) { + PUSH_TOKEN( tokenPtr, i); + } + + // Stack: varWords... idx1 idx2 values... + // {len=[0-2]} { len=numWords-2 } + + /* + * Read the variable. This requires us to copy the varWords first (if there + * are any). + */ + + if (isScalar) { + if (varIdx < 0) { + OP4( OVER, numWords - 2); + OP( LOAD_STK); + } else { + OP4( LOAD_SCALAR, varIdx); + } + } else { + if (varIdx < 0) { + OP4( OVER, numWords - 1); + OP4( OVER, numWords - 1); + OP( LOAD_ARRAY_STK); + } else { + OP4( OVER, numWords - 2); + OP4( LOAD_ARRAY, varIdx); + } + } + + /* + * Move the value read from the variable to the correct stack location for + * the LREPLACE instruction. + */ + + // TODO: Consider a ROLL operation, as in Postscript + // Stack: varWords... idx1 idx2 values... listValue + OP4( REVERSE, numWords - 1); + // Stack: varWords... listValue values... idx2 idx1 + if (numWords > 4) { + OP4( REVERSE, numWords - 2); + } else { + OP( SWAP); + } + // Stack: varWords... listValue idx1 idx2 values... + + /* + * First operand is count of arguments. + * Second operand is bitmask + * TCL_LREPLACE_END_IS_LAST - end refers to last element + */ + OP41( LREPLACE, numWords - 1, + TCL_LREPLACE_END_IS_LAST); + // Stack: varWords... listValue + + /* + * Write back the updated value. We've prepped the stack exactly right for + * this to be something we can Just Do at this point. + */ + + if (isScalar) { + if (varIdx < 0) { + OP( STORE_STK); + } else { + OP4( STORE_SCALAR, varIdx); + } + } else { + if (varIdx < 0) { + OP( STORE_ARRAY_STK); + } else { + OP4( STORE_ARRAY, varIdx); + } + } + + // Stack: listValue + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileLpopCmd -- + * + * How to compile the "lpop" command. We only bother with the case + * where there is a single constant index (or no index) and we're inside + * a procedure-like context. + * + *---------------------------------------------------------------------- + */ +int +TclCompileLpopCmd( + Tcl_Interp *interp, /* Tcl interpreter for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the + * command. */ + TCL_UNUSED(Command *), + CompileEnv *envPtr) /* Holds the resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Size numWords = parsePtr->numWords; + /* TODO: Consider support for compiling expanded args. */ + + // TODO: Figure out all the stack cases here to allow full variable access + // TODO: Find way to handle multiple indices + // (extra opcode for TclLsetFlat with NULL value?) + + if (numWords < 2 || numWords > 3) { + return TCL_ERROR; + } + + Tcl_Token *varTokenPtr = TokenAfter(parsePtr->tokenPtr); + Tcl_LVTIndex varIdx = LocalScalarFromToken(varTokenPtr, envPtr); + if (varIdx < 0) { + // Give up if we pushed any words; makes stack computations tractable + return TCL_ERROR; + } + + Tcl_Token *idxTokenPtr = NULL; + int idx = TCL_INDEX_END, isSimpleIndex = 1; + if (numWords == 3) { + idxTokenPtr = TokenAfter(varTokenPtr); + if (TclGetIndexFromToken(idxTokenPtr, TCL_INDEX_NONE, + TCL_INDEX_NONE, &idx) != TCL_OK) { + /* + * Index isn't simple (e.g., it's a variable read) and could have + * side effects. Need a much more conservative instruction sequence + * to get order of trace-observable operations right. + */ + isSimpleIndex = 0; + } + } + + if (!isSimpleIndex) { + /* + * Push the index token (which may have side effects!) before reading + * the variable, which is "internal" to [lpop]. + */ + + PUSH_TOKEN( idxTokenPtr, 2); + OP4( LOAD_SCALAR, varIdx); + // Stack: index list + OP( SWAP); + // Stack: list index + OP( DUP); + // Stack: list index index + OP4( OVER, 2); + // Stack: list index index list + OP( SWAP); + // Stack: list index list index + OP( LIST_INDEX); + // Stack: list index value + OP4( REVERSE, 3); + // Stack: value index list + OP( SWAP); + } else { + /* + * Can use this much abbreviated form here. In particular, we have a + * parsed index and we can push its value at any time we want, + * including exactly once after reading the variable... + */ + + OP4( LOAD_SCALAR, varIdx); + OP( DUP); + OP4( LIST_INDEX_IMM, idx); + // Stack: list value + OP( SWAP); + if (idxTokenPtr) { + PUSH_SIMPLE_TOKEN( idxTokenPtr); + } else { + PUSH( "end"); + } + } + // Stack: value list index + OP( DUP); + // Stack: value list index index + OP41( LREPLACE, 3, TCL_LREPLACE_END_IS_LAST + | TCL_LREPLACE_NEED_IN_RANGE); + // Stack: value newList + OP4( STORE_SCALAR, varIdx); + OP( POP); + // Stack: value + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileLseqCmd -- + * + * Procedure called to compile the "lseq" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "lseq" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileLseqCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + TCL_UNUSED(Command *), + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; // TIP #280 + Tcl_Token *tokenPtr, *token2Ptr, *token3Ptr, *token4Ptr, *token5Ptr; + int flags; + + if (parsePtr->numWords == 2) { + goto oneArg; + } else if (parsePtr->numWords == 3) { + goto twoArgs; + } else if (parsePtr->numWords == 4) { + goto threeArgs; + } else if (parsePtr->numWords == 5) { + goto fourArgs; + } else if (parsePtr->numWords == 6) { + goto fiveArgs; + } else { + // This is a syntax error case. + return TCL_ERROR; + } + +#define IS_ANY_LSEQ_KEYWORD(tokenPtr) \ + (IS_TOKEN_LITERALLY(tokenPtr, "to") \ + || IS_TOKEN_LITERALLY(tokenPtr, "..") \ + || IS_TOKEN_LITERALLY(tokenPtr, "count") \ + || IS_TOKEN_LITERALLY(tokenPtr, "by")) + + // Handle [lseq $n] + oneArg: + tokenPtr = TokenAfter(parsePtr->tokenPtr); + flags = (TCL_ARITHSERIES_FROM | TCL_ARITHSERIES_STEP | + TCL_ARITHSERIES_COUNT); + if (IS_ANY_LSEQ_KEYWORD(tokenPtr)) { + return TCL_ERROR; + } + PUSH( "0"); // from + PUSH( ""); // to + PUSH( "1"); // step + PUSH_TOKEN( tokenPtr, 1); // count + OP1( ARITH_SERIES, flags); + return TCL_OK; + // Handle [lseq $m $n] + twoArgs: + tokenPtr = TokenAfter(parsePtr->tokenPtr); + token2Ptr = TokenAfter(tokenPtr); + flags = (TCL_ARITHSERIES_FROM | TCL_ARITHSERIES_TO); + if (IS_ANY_LSEQ_KEYWORD(tokenPtr) || IS_ANY_LSEQ_KEYWORD(token2Ptr)) { + return TCL_ERROR; + } + PUSH_TOKEN( tokenPtr, 1); // from + PUSH_TOKEN( token2Ptr, 2); // to + PUSH( ""); // step + PUSH( ""); // count + OP1( ARITH_SERIES, flags); + return TCL_OK; + + // Handle [lseq $x $y $z], [lseq $x to $y], [lseq $x count $y], [lseq $x by $y] + threeArgs: + tokenPtr = TokenAfter(parsePtr->tokenPtr); + token2Ptr = TokenAfter(tokenPtr); + token3Ptr = TokenAfter(token2Ptr); + if (IS_ANY_LSEQ_KEYWORD(tokenPtr) || IS_ANY_LSEQ_KEYWORD(token3Ptr)) { + return TCL_ERROR; + } + if (IS_TOKEN_LITERALLY(token2Ptr, "to") || IS_TOKEN_LITERALLY(token2Ptr, "..")) { + flags = (TCL_ARITHSERIES_FROM | TCL_ARITHSERIES_TO); + PUSH_TOKEN( tokenPtr, 1); // from + PUSH_TOKEN( token3Ptr, 3); // to + PUSH( ""); // step + PUSH( ""); // count + } else if (IS_TOKEN_LITERALLY(token2Ptr, "count")) { + flags = (TCL_ARITHSERIES_FROM | TCL_ARITHSERIES_STEP | TCL_ARITHSERIES_COUNT); + PUSH_TOKEN( tokenPtr, 1); // from + PUSH( ""); // to + PUSH( "1"); // step + PUSH_TOKEN( token3Ptr, 3); // count + } else if (IS_TOKEN_LITERALLY(token2Ptr, "by")) { + flags = (TCL_ARITHSERIES_FROM | TCL_ARITHSERIES_STEP | TCL_ARITHSERIES_COUNT); + PUSH( "0"); // from + PUSH( ""); // to + PUSH_TOKEN( tokenPtr, 1); // count + PUSH_TOKEN( token3Ptr, 3); // step + OP( SWAP); + } else { + flags = (TCL_ARITHSERIES_FROM | TCL_ARITHSERIES_TO | TCL_ARITHSERIES_STEP); + PUSH_TOKEN( tokenPtr, 1); // from + PUSH_TOKEN( token2Ptr, 2); // to + PUSH_TOKEN( token3Ptr, 3); // step + PUSH( ""); // count + } + OP1( ARITH_SERIES, flags); return TCL_OK; + + // Handle [lseq $x to $y $z], [lseq $x $y by $z], [lseq $x count $y $z] + fourArgs: + tokenPtr = TokenAfter(parsePtr->tokenPtr); + token2Ptr = TokenAfter(tokenPtr); + token3Ptr = TokenAfter(token2Ptr); + token4Ptr = TokenAfter(token3Ptr); + if (IS_ANY_LSEQ_KEYWORD(tokenPtr) || IS_ANY_LSEQ_KEYWORD(token4Ptr)) { + return TCL_ERROR; + } + if (IS_TOKEN_LITERALLY(token2Ptr, "to") || IS_TOKEN_LITERALLY(token2Ptr, "..")) { + flags = (TCL_ARITHSERIES_FROM | TCL_ARITHSERIES_TO | TCL_ARITHSERIES_STEP); + if (IS_ANY_LSEQ_KEYWORD(token3Ptr)) { + return TCL_ERROR; + } + PUSH_TOKEN( tokenPtr, 1); // from + PUSH_TOKEN( token3Ptr, 3); // to + PUSH_TOKEN( token4Ptr, 4); // step + PUSH( ""); // count + } else if (IS_TOKEN_LITERALLY(token2Ptr, "count")) { + flags = (TCL_ARITHSERIES_FROM | TCL_ARITHSERIES_STEP | TCL_ARITHSERIES_COUNT); + if (IS_ANY_LSEQ_KEYWORD(token3Ptr)) { + return TCL_ERROR; + } + PUSH_TOKEN( tokenPtr, 1); // from + PUSH( ""); // to + PUSH_TOKEN( token3Ptr, 3); // count + PUSH_TOKEN( token4Ptr, 4); // step + OP( SWAP); + } else if (IS_TOKEN_LITERALLY(token3Ptr, "by")) { + flags = (TCL_ARITHSERIES_FROM | TCL_ARITHSERIES_TO | TCL_ARITHSERIES_STEP); + if (IS_ANY_LSEQ_KEYWORD(token3Ptr)) { + return TCL_ERROR; + } + PUSH_TOKEN( tokenPtr, 1); // from + PUSH_TOKEN( token2Ptr, 2); // to + PUSH_TOKEN( token4Ptr, 4); // step + PUSH( ""); // count + } else { + return TCL_ERROR; + } + OP1( ARITH_SERIES, flags); + return TCL_OK; + + // Handle [lseq $x to $y by $z], [lseq $x count $y by $z] + fiveArgs: + tokenPtr = TokenAfter(parsePtr->tokenPtr); + token2Ptr = TokenAfter(tokenPtr); + token3Ptr = TokenAfter(token2Ptr); + token4Ptr = TokenAfter(token3Ptr); + token5Ptr = TokenAfter(token4Ptr); + if (IS_ANY_LSEQ_KEYWORD(tokenPtr) || IS_ANY_LSEQ_KEYWORD(token3Ptr) + || IS_ANY_LSEQ_KEYWORD(token5Ptr)) { + return TCL_ERROR; + } + if (!IS_TOKEN_LITERALLY(token4Ptr, "by")) { + return TCL_ERROR; + } + if (IS_TOKEN_LITERALLY(token2Ptr, "to") || IS_TOKEN_LITERALLY(token2Ptr, "..")) { + flags = (TCL_ARITHSERIES_FROM | TCL_ARITHSERIES_TO | TCL_ARITHSERIES_STEP); + PUSH_TOKEN( tokenPtr, 1); // from + PUSH_TOKEN( token3Ptr, 3); // to + PUSH_TOKEN( token5Ptr, 5); // step + PUSH( ""); // count + } else if (IS_TOKEN_LITERALLY(token2Ptr, "count")) { + flags = (TCL_ARITHSERIES_FROM | TCL_ARITHSERIES_STEP | TCL_ARITHSERIES_COUNT); + PUSH_TOKEN( tokenPtr, 1); // from + PUSH( ""); // to + PUSH_TOKEN( token3Ptr, 3); // count + PUSH_TOKEN( token5Ptr, 5); // step + OP( SWAP); + } else { + return TCL_ERROR; + } + OP1( ARITH_SERIES, flags); + return TCL_OK; + +#undef IS_ANY_LSEQ_KEYWORD } /* @@ -1490,20 +1953,20 @@ TclCompileLsetCmd( CompileEnv *envPtr) /* Holds the resulting instructions. */ { DefineLineInformation; /* TIP #280 */ - int tempDepth; /* Depth used for emitting one part of the + Tcl_Size tempDepth; /* Depth used for emitting one part of the * code burst. */ Tcl_Token *varTokenPtr; /* Pointer to the Tcl_Token representing the * parse of the variable name. */ - int localIndex; /* Index of var in local var table. */ + Tcl_LVTIndex localIndex; /* Index of var in local var table. */ int isScalar; /* Flag == 1 if scalar, 0 if array. */ - int i; + Tcl_Size i, numWords = parsePtr->numWords; /* * Check argument count. */ /* TODO: Consider support for compiling expanded args. */ - if ((int)parsePtr->numWords < 3) { + if (numWords < 3 || numWords > UINT_MAX) { /* * Fail at run time, not in compilation. */ @@ -1520,16 +1983,15 @@ TclCompileLsetCmd( */ varTokenPtr = TokenAfter(parsePtr->tokenPtr); - PushVarNameWord(interp, varTokenPtr, envPtr, 0, - &localIndex, &isScalar, 1); + PushVarNameWord(varTokenPtr, 0, &localIndex, &isScalar, 1); /* * Push the "index" args and the new element value. */ - for (i=2 ; i<(int)parsePtr->numWords ; ++i) { + for (i=2 ; i<numWords ; ++i) { varTokenPtr = TokenAfter(varTokenPtr); - CompileWord(envPtr, varTokenPtr, interp, i); + PUSH_TOKEN( varTokenPtr, i); } /* @@ -1537,12 +1999,8 @@ TclCompileLsetCmd( */ if (localIndex < 0) { - if (isScalar) { - tempDepth = parsePtr->numWords - 2; - } else { - tempDepth = parsePtr->numWords - 1; - } - TclEmitInstInt4( INST_OVER, tempDepth, envPtr); + tempDepth = numWords - (isScalar ? 2 : 1); + OP4( OVER, tempDepth); } /* @@ -1550,12 +2008,8 @@ TclCompileLsetCmd( */ if (!isScalar) { - if (localIndex < 0) { - tempDepth = parsePtr->numWords - 1; - } else { - tempDepth = parsePtr->numWords - 2; - } - TclEmitInstInt4( INST_OVER, tempDepth, envPtr); + tempDepth = numWords - (localIndex >= 0 ? 2 : 1); + OP4( OVER, tempDepth); } /* @@ -1564,15 +2018,15 @@ TclCompileLsetCmd( if (isScalar) { if (localIndex < 0) { - TclEmitOpcode( INST_LOAD_STK, envPtr); + OP( LOAD_STK); } else { - Emit14Inst( INST_LOAD_SCALAR, localIndex, envPtr); + OP4( LOAD_SCALAR, localIndex); } } else { if (localIndex < 0) { - TclEmitOpcode( INST_LOAD_ARRAY_STK, envPtr); + OP( LOAD_ARRAY_STK); } else { - Emit14Inst( INST_LOAD_ARRAY, localIndex, envPtr); + OP4( LOAD_ARRAY, localIndex); } } @@ -1580,10 +2034,10 @@ TclCompileLsetCmd( * Emit the correct variety of 'lset' instruction. */ - if (parsePtr->numWords == 4) { - TclEmitOpcode( INST_LSET_LIST, envPtr); + if (numWords == 4) { + OP( LSET_LIST); } else { - TclEmitInstInt4( INST_LSET_FLAT, parsePtr->numWords-1, envPtr); + OP4( LSET_FLAT, numWords - 1); } /* @@ -1592,15 +2046,15 @@ TclCompileLsetCmd( if (isScalar) { if (localIndex < 0) { - TclEmitOpcode( INST_STORE_STK, envPtr); + OP( STORE_STK); } else { - Emit14Inst( INST_STORE_SCALAR, localIndex, envPtr); + OP4( STORE_SCALAR, localIndex); } } else { if (localIndex < 0) { - TclEmitOpcode( INST_STORE_ARRAY_STK, envPtr); + OP( STORE_ARRAY_STK); } else { - Emit14Inst( INST_STORE_ARRAY, localIndex, envPtr); + OP4( STORE_ARRAY, localIndex); } } @@ -1647,7 +2101,7 @@ TclCompileNamespaceCurrentCmd( * Not much to do; we compile to a single instruction... */ - TclEmitOpcode( INST_NS_CURRENT, envPtr); + OP( NS_CURRENT); return TCL_OK; } @@ -1674,8 +2128,8 @@ TclCompileNamespaceCodeCmd( * but what the test suite checks for. */ - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || (tokenPtr[1].size > 20 - && strncmp(tokenPtr[1].start, "::namespace inscope ", 20) == 0)) { + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || + IS_TOKEN_PREFIXED_BY(tokenPtr, "::namespace inscope ")) { /* * Technically, we could just pass a literal '::namespace inscope ' * term through, but that's something which really shouldn't be @@ -1692,11 +2146,11 @@ TclCompileNamespaceCodeCmd( * the value needs to be determined at runtime for safety. */ - PushStringLiteral(envPtr, "::namespace"); - PushStringLiteral(envPtr, "inscope"); - TclEmitOpcode( INST_NS_CURRENT, envPtr); - CompileWord(envPtr, tokenPtr, interp, 1); - TclEmitInstInt4( INST_LIST, 4, envPtr); + PUSH( "::namespace"); + PUSH( "inscope"); + OP( NS_CURRENT); + PUSH_TOKEN( tokenPtr, 1); + OP4( LIST, 4); return TCL_OK; } @@ -1716,8 +2170,8 @@ TclCompileNamespaceOriginCmd( } tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); - TclEmitOpcode( INST_ORIGIN_COMMAND, envPtr); + PUSH_TOKEN( tokenPtr, 1); + OP( ORIGIN_COMMAND); return TCL_OK; } @@ -1731,28 +2185,27 @@ TclCompileNamespaceQualifiersCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); - int off; + Tcl_BytecodeLabel off; if (parsePtr->numWords != 2) { return TCL_ERROR; } - CompileWord(envPtr, tokenPtr, interp, 1); - PushStringLiteral(envPtr, "0"); - PushStringLiteral(envPtr, "::"); - TclEmitInstInt4( INST_OVER, 2, envPtr); - TclEmitOpcode( INST_STR_FIND_LAST, envPtr); - off = CurrentOffset(envPtr); - PushStringLiteral(envPtr, "1"); - TclEmitOpcode( INST_SUB, envPtr); - TclEmitInstInt4( INST_OVER, 2, envPtr); - TclEmitInstInt4( INST_OVER, 1, envPtr); - TclEmitOpcode( INST_STR_INDEX, envPtr); - PushStringLiteral(envPtr, ":"); - TclEmitOpcode( INST_STR_EQ, envPtr); - off = off - CurrentOffset(envPtr); - TclEmitInstInt1( INST_JUMP_TRUE1, off, envPtr); - TclEmitOpcode( INST_STR_RANGE, envPtr); + PUSH_TOKEN( tokenPtr, 1); + PUSH( "0"); + PUSH( "::"); + OP4( OVER, 2); + OP( STR_FIND_LAST); + BACKLABEL( off); + PUSH( "1"); + OP( SUB); + OP4( OVER, 2); + OP4( OVER, 1); + OP( STR_INDEX); + PUSH( ":"); + OP( STR_EQ); + BACKJUMP( JUMP_TRUE, off); + OP( STR_RANGE); return TCL_OK; } @@ -1766,7 +2219,7 @@ TclCompileNamespaceTailCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); - JumpFixup jumpFixup; + Tcl_BytecodeLabel dontSkipSeparator; if (parsePtr->numWords != 2) { return TCL_ERROR; @@ -1776,19 +2229,19 @@ TclCompileNamespaceTailCmd( * Take care; only add 2 to found index if the string was actually found. */ - CompileWord(envPtr, tokenPtr, interp, 1); - PushStringLiteral(envPtr, "::"); - TclEmitInstInt4( INST_OVER, 1, envPtr); - TclEmitOpcode( INST_STR_FIND_LAST, envPtr); - TclEmitOpcode( INST_DUP, envPtr); - PushStringLiteral(envPtr, "0"); - TclEmitOpcode( INST_GE, envPtr); - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFixup); - PushStringLiteral(envPtr, "2"); - TclEmitOpcode( INST_ADD, envPtr); - TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127); - PushStringLiteral(envPtr, "end"); - TclEmitOpcode( INST_STR_RANGE, envPtr); + PUSH_TOKEN( tokenPtr, 1); + PUSH( "::"); + OP4( OVER, 1); + OP( STR_FIND_LAST); + OP( DUP); + PUSH( "0"); + OP( GE); + FWDJUMP( JUMP_FALSE, dontSkipSeparator); + PUSH( "2"); + OP( ADD); + FWDLABEL( dontSkipSeparator); + PUSH( "end"); + OP( STR_RANGE); return TCL_OK; } @@ -1802,9 +2255,10 @@ TclCompileNamespaceUpvarCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr, *otherTokenPtr, *localTokenPtr; - int localIndex, numWords, i; + Tcl_LVTIndex localIndex; + Tcl_Size numWords = parsePtr->numWords, i; - if (envPtr->procPtr == NULL) { + if (!EnvIsProc(envPtr)) { return TCL_ERROR; } @@ -1812,8 +2266,7 @@ TclCompileNamespaceUpvarCmd( * Only compile [namespace upvar ...]: needs an even number of args, >=4 */ - numWords = (int)parsePtr->numWords; - if ((numWords % 2) || (numWords < 4)) { + if ((numWords % 2) || numWords < 4 || numWords > UINT_MAX) { return TCL_ERROR; } @@ -1822,7 +2275,7 @@ TclCompileNamespaceUpvarCmd( */ tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); + PUSH_TOKEN( tokenPtr, 1); /* * Loop over the (otherVar, thisVar) pairs. If any of the thisVar is not a @@ -1835,20 +2288,20 @@ TclCompileNamespaceUpvarCmd( otherTokenPtr = TokenAfter(localTokenPtr); localTokenPtr = TokenAfter(otherTokenPtr); - CompileWord(envPtr, otherTokenPtr, interp, i); + PUSH_TOKEN( otherTokenPtr, i); localIndex = LocalScalarFromToken(localTokenPtr, envPtr); if (localIndex < 0) { return TCL_ERROR; } - TclEmitInstInt4( INST_NSUPVAR, localIndex, envPtr); + OP4( NSUPVAR, localIndex); } /* * Pop the namespace, and set the result to empty */ - TclEmitOpcode( INST_POP, envPtr); - PushStringLiteral(envPtr, ""); + OP( POP); + PUSH( ""); return TCL_OK; } @@ -1861,10 +2314,10 @@ TclCompileNamespaceWhichCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ - Tcl_Token *tokenPtr, *opt; - int idx; + Tcl_Token *tokenPtr; + Tcl_Size numWords = parsePtr->numWords, idx; - if ((int)parsePtr->numWords < 2 || (int)parsePtr->numWords > 3) { + if (numWords < 2 || numWords > 3) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -1875,13 +2328,8 @@ TclCompileNamespaceWhichCmd( * "-variable" (currently) and anything else is an error. */ - if (parsePtr->numWords == 3) { - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TCL_ERROR; - } - opt = tokenPtr + 1; - if (opt->size < 2 || opt->size > 8 - || strncmp(opt->start, "-command", opt->size) != 0) { + if (numWords == 3) { + if (!IS_TOKEN_PREFIX(tokenPtr, 2, "-command")) { return TCL_ERROR; } tokenPtr = TokenAfter(tokenPtr); @@ -1892,8 +2340,8 @@ TclCompileNamespaceWhichCmd( * Issue the bytecode. */ - CompileWord(envPtr, tokenPtr, interp, idx); - TclEmitOpcode( INST_RESOLVE_COMMAND, envPtr); + PUSH_TOKEN( tokenPtr, idx); + OP( RESOLVE_COMMAND); return TCL_OK; } @@ -1927,7 +2375,8 @@ TclCompileRegexpCmd( Tcl_Token *varTokenPtr; /* Pointer to the Tcl_Token representing the * parse of the RE or string. */ size_t len; - int i, nocase, exact, sawLast, simple; + Tcl_Size i, numWords = parsePtr->numWords; + int nocase, exact, sawLast, simple; const char *str; /* @@ -1937,7 +2386,7 @@ TclCompileRegexpCmd( * regexp ?-nocase? ?--? {^staticString$} $var */ - if ((int)parsePtr->numWords < 3) { + if (numWords < 3 || numWords > UINT_MAX) { return TCL_ERROR; } @@ -1952,33 +2401,24 @@ TclCompileRegexpCmd( * handling, but satisfies our stricter needs. */ - for (i = 1; i < (int)parsePtr->numWords - 2; i++) { + for (i = 1; i < numWords - 2; i++) { varTokenPtr = TokenAfter(varTokenPtr); - if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - /* - * Not a simple string, so punt to runtime. - */ - - return TCL_ERROR; - } - str = varTokenPtr[1].start; - len = varTokenPtr[1].size; - if ((len == 2) && (str[0] == '-') && (str[1] == '-')) { + if (IS_TOKEN_LITERALLY(varTokenPtr, "--")) { sawLast++; i++; break; - } else if ((len > 1) && (strncmp(str, "-nocase", len) == 0)) { + } else if (IS_TOKEN_PREFIX(varTokenPtr, 2, "-nocase")) { nocase = 1; } else { /* - * Not an option we recognize. + * Not an option we recognize or something the compiler can't see. */ return TCL_ERROR; } } - if (((int)parsePtr->numWords - i) != 2) { + if (numWords - i != 2) { /* * We don't support capturing to variables. */ @@ -2013,7 +2453,7 @@ TclCompileRegexpCmd( * The semantics of regexp are always match on re == "". */ - PushStringLiteral(envPtr, "1"); + PUSH( "1"); return TCL_OK; } @@ -2022,16 +2462,15 @@ TclCompileRegexpCmd( * converted pattern as a literal. */ - if (TclReToGlob(NULL, varTokenPtr[1].start, len, &ds, &exact, NULL) - == TCL_OK) { + if (TclReToGlob(NULL, str, len, &ds, &exact, NULL) == TCL_OK) { simple = 1; - PushLiteral(envPtr, Tcl_DStringValue(&ds),Tcl_DStringLength(&ds)); + TclPushDString(envPtr, &ds); Tcl_DStringFree(&ds); } } if (!simple) { - CompileWord(envPtr, varTokenPtr, interp, (int)parsePtr->numWords - 2); + PUSH_TOKEN( varTokenPtr, numWords - 2); } /* @@ -2039,13 +2478,13 @@ TclCompileRegexpCmd( */ varTokenPtr = TokenAfter(varTokenPtr); - CompileWord(envPtr, varTokenPtr, interp, (int)parsePtr->numWords - 1); + PUSH_TOKEN( varTokenPtr, numWords - 1); if (simple) { if (exact && !nocase) { - TclEmitOpcode( INST_STR_EQ, envPtr); + OP( STR_EQ); } else { - TclEmitInstInt1( INST_STR_MATCH, nocase, envPtr); + OP1( STR_MATCH, nocase); } } else { /* @@ -2056,7 +2495,7 @@ TclCompileRegexpCmd( int cflags = TCL_REG_ADVANCED | (nocase ? TCL_REG_NOCASE : 0); - TclEmitInstInt1( INST_REGEXP, cflags, envPtr); + OP1( REGEXP, cflags); } return TCL_OK; @@ -2109,6 +2548,7 @@ TclCompileRegsubCmd( */ DefineLineInformation; /* TIP #280 */ + Tcl_Size numWords = parsePtr->numWords; Tcl_Token *tokenPtr, *stringTokenPtr; Tcl_Obj *patternObj = NULL, *replacementObj = NULL; Tcl_DString pattern; @@ -2116,7 +2556,7 @@ TclCompileRegsubCmd( int exact, quantified, result = TCL_ERROR; Tcl_Size len; - if ((int)parsePtr->numWords < 5 || (int)parsePtr->numWords > 6) { + if (numWords < 5 || numWords > 6) { return TCL_ERROR; } @@ -2126,8 +2566,7 @@ TclCompileRegsubCmd( */ tokenPtr = TokenAfter(parsePtr->tokenPtr); - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size != 4 - || strncmp(tokenPtr[1].start, "-all", 4)) { + if (!IS_TOKEN_LITERALLY(tokenPtr, "-all")) { return TCL_ERROR; } @@ -2142,17 +2581,16 @@ TclCompileRegsubCmd( goto done; } if (TclGetString(patternObj)[0] == '-') { - if (strcmp(TclGetString(patternObj), "--") != 0 - || parsePtr->numWords == 5) { + if (strcmp(TclGetString(patternObj), "--") != 0 || numWords == 5) { goto done; } tokenPtr = TokenAfter(tokenPtr); - Tcl_DecrRefCount(patternObj); + Tcl_BounceRefCount(patternObj); TclNewObj(patternObj); if (!TclWordKnownAtCompileTime(tokenPtr, patternObj)) { goto done; } - } else if (parsePtr->numWords == 6) { + } else if (numWords == 6) { goto done; } @@ -2222,19 +2660,14 @@ TclCompileRegsubCmd( result = TCL_OK; bytes = Tcl_DStringValue(&pattern) + 1; PushLiteral(envPtr, bytes, len); - bytes = TclGetStringFromObj(replacementObj, &len); - PushLiteral(envPtr, bytes, len); - CompileWord(envPtr, stringTokenPtr, interp, (int)parsePtr->numWords - 2); - TclEmitOpcode( INST_STR_MAP, envPtr); + PUSH_OBJ( replacementObj); + PUSH_TOKEN( stringTokenPtr, numWords - 2); + OP( STR_MAP); done: Tcl_DStringFree(&pattern); - if (patternObj) { - Tcl_DecrRefCount(patternObj); - } - if (replacementObj) { - Tcl_DecrRefCount(replacementObj); - } + Tcl_BounceRefCount(patternObj); + Tcl_BounceRefCount(replacementObj); return result; } @@ -2271,12 +2704,16 @@ TclCompileReturnCmd( */ int level, code, objc, status = TCL_OK; Tcl_Size size; - int numWords = parsePtr->numWords; + Tcl_Size numWords = parsePtr->numWords; int explicitResult = (0 == (numWords % 2)); - int numOptionWords = numWords - 1 - explicitResult; + Tcl_Size numOptionWords = numWords - 1 - explicitResult; Tcl_Obj *returnOpts, **objv; Tcl_Token *wordTokenPtr = TokenAfter(parsePtr->tokenPtr); + if (numWords > UINT_MAX) { + return TCL_ERROR; + } + /* * Check for special case which can always be compiled: * return -options <opts> <msg> @@ -2286,15 +2723,13 @@ TclCompileReturnCmd( * ('finally' clause processing) this piece of code would not be present. */ - if ((numWords == 4) && (wordTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) - && (wordTokenPtr[1].size == 8) - && (strncmp(wordTokenPtr[1].start, "-options", 8) == 0)) { + if ((numWords == 4) && IS_TOKEN_LITERALLY(wordTokenPtr, "-options")) { Tcl_Token *optsTokenPtr = TokenAfter(wordTokenPtr); Tcl_Token *msgTokenPtr = TokenAfter(optsTokenPtr); - CompileWord(envPtr, optsTokenPtr, interp, 2); - CompileWord(envPtr, msgTokenPtr, interp, 3); - TclEmitInvoke(envPtr, INST_RETURN_STK); + PUSH_TOKEN( optsTokenPtr, 2); + PUSH_TOKEN( msgTokenPtr, 3); + INVOKE( RETURN_STK); return TCL_OK; } @@ -2302,7 +2737,8 @@ TclCompileReturnCmd( * Allocate some working space. */ - objv = (Tcl_Obj **)TclStackAlloc(interp, numOptionWords * sizeof(Tcl_Obj *)); + objv = (Tcl_Obj **)TclStackAlloc(interp, + numOptionWords * sizeof(Tcl_Obj *)); /* * Scan through the return options. If any are unknown at compile time, @@ -2353,13 +2789,13 @@ TclCompileReturnCmd( */ if (explicitResult) { - CompileWord(envPtr, wordTokenPtr, interp, numWords - 1); + PUSH_TOKEN( wordTokenPtr, numWords - 1); } else { /* * No explict result argument, so default result is empty string. */ - PushStringLiteral(envPtr, ""); + PUSH( ""); } /* @@ -2368,19 +2804,19 @@ TclCompileReturnCmd( * instruction is equivalent, and may be more efficient. */ - if (numOptionWords == 0 && envPtr->procPtr != NULL) { + if (numOptionWords == 0 && EnvIsProc(envPtr)) { /* * We have default return options and we're in a proc ... */ - int index = envPtr->exceptArrayNext - 1; + Tcl_ExceptionRange index = envPtr->exceptArrayNext - 1; int enclosingCatch = 0; while (index >= 0) { - ExceptionRange range = envPtr->exceptArrayPtr[index]; + const ExceptionRange *rangePtr = &envPtr->exceptArrayPtr[index]; - if ((range.type == CATCH_EXCEPTION_RANGE) - && (range.catchOffset == TCL_INDEX_NONE)) { + if ((rangePtr->type == CATCH_EXCEPTION_RANGE) + && (rangePtr->catchOffset == TCL_INDEX_NONE)) { enclosingCatch = 1; break; } @@ -2393,8 +2829,8 @@ TclCompileReturnCmd( */ Tcl_DecrRefCount(returnOpts); - TclEmitOpcode(INST_DONE, envPtr); - TclAdjustStackDepth(1, envPtr); + OP( DONE); + STKDELTA(+1); return TCL_OK; } } @@ -2421,26 +2857,26 @@ TclCompileReturnCmd( wordTokenPtr = TokenAfter(parsePtr->tokenPtr); for (objc=1 ; objc<=numOptionWords ; objc++) { - CompileWord(envPtr, wordTokenPtr, interp, objc); + PUSH_TOKEN( wordTokenPtr, objc); wordTokenPtr = TokenAfter(wordTokenPtr); } - TclEmitInstInt4(INST_LIST, numOptionWords, envPtr); + OP4( LIST, numOptionWords); /* * Push the result. */ if (explicitResult) { - CompileWord(envPtr, wordTokenPtr, interp, numWords - 1); + PUSH_TOKEN( wordTokenPtr, numWords - 1); } else { - PushStringLiteral(envPtr, ""); + PUSH( ""); } /* * Issue the RETURN itself. */ - TclEmitInvoke(envPtr, INST_RETURN_STK); + INVOKE( RETURN_STK); return TCL_OK; } @@ -2469,9 +2905,8 @@ CompileReturnInternal( } } - TclEmitPush(TclAddLiteralObj(envPtr, returnOpts, NULL), envPtr); - TclEmitInstInt4(op, code, envPtr); - TclEmitInt4(level, envPtr); + PUSH_OBJ( returnOpts); + TclEmitInstInt44(op, code, level, envPtr); } void @@ -2484,7 +2919,7 @@ TclCompileSyntaxError( const char *bytes = TclGetStringFromObj(msg, &numBytes); TclErrorStackResetIf(interp, bytes, numBytes); - TclEmitPush(TclRegisterLiteral(envPtr, bytes, numBytes, 0), envPtr); + PUSH_OBJ( msg); CompileReturnInternal(envPtr, INST_SYNTAX, TCL_ERROR, 0, TclNoErrorStack(interp, Tcl_GetReturnOptions(interp, TCL_ERROR))); Tcl_ResetResult(interp); @@ -2518,15 +2953,15 @@ TclCompileUpvarCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr, *otherTokenPtr, *localTokenPtr; - int localIndex, numWords, i; + Tcl_LVTIndex localIndex; + Tcl_Size numWords = parsePtr->numWords, i; Tcl_Obj *objPtr; - if (envPtr->procPtr == NULL) { + if (!EnvIsProc(envPtr)) { return TCL_ERROR; } - numWords = parsePtr->numWords; - if (numWords < 3) { + if (numWords < 3 || numWords > UINT_MAX) { return TCL_ERROR; } @@ -2537,31 +2972,26 @@ TclCompileUpvarCmd( TclNewObj(objPtr); tokenPtr = TokenAfter(parsePtr->tokenPtr); if (TclWordKnownAtCompileTime(tokenPtr, objPtr)) { - CallFrame *framePtr; - const Tcl_ObjType *newTypePtr, *typePtr = objPtr->typePtr; - /* - * Attempt to convert to a level reference. Note that TclObjGetFrame - * only changes the obj type when a conversion was successful. + * Attempt to convert to a level reference. */ - TclObjGetFrame(interp, objPtr, &framePtr); - newTypePtr = objPtr->typePtr; + int numFrameWords = TclObjGetFrame(interp, objPtr, NULL); Tcl_DecrRefCount(objPtr); - if (newTypePtr != typePtr) { - if (numWords%2) { + if (numFrameWords) { + if (numWords % 2) { return TCL_ERROR; } /* TODO: Push the known value instead? */ - CompileWord(envPtr, tokenPtr, interp, 1); + PUSH_TOKEN( tokenPtr, 1); otherTokenPtr = TokenAfter(tokenPtr); i = 2; } else { - if (!(numWords%2)) { + if (!(numWords % 2)) { return TCL_ERROR; } - PushStringLiteral(envPtr, "1"); + PUSH( "1"); otherTokenPtr = tokenPtr; i = 1; } @@ -2579,20 +3009,20 @@ TclCompileUpvarCmd( for (; i<numWords; i+=2, otherTokenPtr = TokenAfter(localTokenPtr)) { localTokenPtr = TokenAfter(otherTokenPtr); - CompileWord(envPtr, otherTokenPtr, interp, i); + PUSH_TOKEN( otherTokenPtr, i); localIndex = LocalScalarFromToken(localTokenPtr, envPtr); if (localIndex < 0) { return TCL_ERROR; } - TclEmitInstInt4( INST_UPVAR, localIndex, envPtr); + OP4( UPVAR, localIndex); } /* * Pop the frame index, and set the result to empty */ - TclEmitOpcode( INST_POP, envPtr); - PushStringLiteral(envPtr, ""); + OP( POP); + PUSH( ""); return TCL_OK; } @@ -2624,10 +3054,10 @@ TclCompileVariableCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr, *valueTokenPtr; - int localIndex, numWords, i; + Tcl_LVTIndex localIndex; + Tcl_Size numWords = parsePtr->numWords, i; - numWords = parsePtr->numWords; - if (numWords < 2) { + if (numWords < 2 || numWords > UINT_MAX) { return TCL_ERROR; } @@ -2635,7 +3065,7 @@ TclCompileVariableCmd( * Bail out if not compiling a proc body */ - if (envPtr->procPtr == NULL) { + if (!EnvIsProc(envPtr)) { return TCL_ERROR; } @@ -2657,17 +3087,17 @@ TclCompileVariableCmd( /* TODO: Consider what value can pass through the * IndexTailVarIfKnown() screen. Full CompileWord() * likely does not apply here. Push known value instead. */ - CompileWord(envPtr, varTokenPtr, interp, i); - TclEmitInstInt4( INST_VARIABLE, localIndex, envPtr); + PUSH_TOKEN( varTokenPtr, i); + OP4( VARIABLE, localIndex); if (i + 1 < numWords) { /* * A value has been given: set the variable, pop the value */ - CompileWord(envPtr, valueTokenPtr, interp, i + 1); - Emit14Inst( INST_STORE_SCALAR, localIndex, envPtr); - TclEmitOpcode( INST_POP, envPtr); + PUSH_TOKEN( valueTokenPtr, i + 1); + OP4( STORE_SCALAR, localIndex); + OP( POP); } } @@ -2675,7 +3105,7 @@ TclCompileVariableCmd( * Set the result to empty */ - PushStringLiteral(envPtr, ""); + PUSH( ""); return TCL_OK; } @@ -2698,7 +3128,7 @@ TclCompileVariableCmd( *---------------------------------------------------------------------- */ -static int +static Tcl_LVTIndex IndexTailVarIfKnown( TCL_UNUSED(Tcl_Interp *), Tcl_Token *varTokenPtr, /* Token representing the variable name */ @@ -2706,10 +3136,10 @@ IndexTailVarIfKnown( { Tcl_Obj *tailPtr; const char *tailName, *p; - int n = varTokenPtr->numComponents; - Tcl_Size len; + Tcl_Size n = varTokenPtr->numComponents, len; Tcl_Token *lastTokenPtr; - int full, localIndex; + int full; + Tcl_LVTIndex localIndex; /* * Determine if the tail is (a) known at compile time, and (b) not an @@ -2721,7 +3151,7 @@ IndexTailVarIfKnown( */ if (!EnvHasLVT(envPtr)) { - return -1; + return TCL_INDEX_NONE; } TclNewObj(tailPtr); @@ -2734,7 +3164,7 @@ IndexTailVarIfKnown( if (lastTokenPtr->type != TCL_TOKEN_TEXT) { Tcl_DecrRefCount(tailPtr); - return -1; + return TCL_INDEX_NONE; } Tcl_SetStringObj(tailPtr, lastTokenPtr->start, lastTokenPtr->size); } @@ -2748,14 +3178,14 @@ IndexTailVarIfKnown( */ Tcl_DecrRefCount(tailPtr); - return -1; + return TCL_INDEX_NONE; } /* * Get the tail: immediately after the last '::' */ - for (p = tailName + len -1; p > tailName; p--) { + for (p = tailName + len - 1; p > tailName; p--) { if ((p[0] == ':') && (p[- 1] == ':')) { p++; break; @@ -2767,7 +3197,7 @@ IndexTailVarIfKnown( */ Tcl_DecrRefCount(tailPtr); - return -1; + return TCL_INDEX_NONE; } len -= p - tailName; tailName = p; @@ -2798,17 +3228,72 @@ TclCompileObjectNextCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr = parsePtr->tokenPtr; - int i; + Tcl_Size i, numWords = parsePtr->numWords; - if ((int)parsePtr->numWords > 255) { - return TCL_ERROR; + if (parsePtr->numWords > UINT_MAX) { + goto issueExpanded; } - for (i=0 ; i<(int)parsePtr->numWords ; i++) { - CompileWord(envPtr, tokenPtr, interp, i); + // Check for expansion + for (i=0 ; i<numWords ; i++) { + if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { + goto issueExpanded; + } + tokenPtr = TokenAfter(tokenPtr); + } + + // Simple instruction issue + tokenPtr = parsePtr->tokenPtr; + for (i=0 ; i<numWords ; i++) { + PUSH_TOKEN( tokenPtr, i); tokenPtr = TokenAfter(tokenPtr); } - TclEmitInstInt1( INST_TCLOO_NEXT, i, envPtr); + INVOKE4( TCLOO_NEXT, i); + return TCL_OK; + + issueExpanded: + // Concatenate all arguments into a list; handles expansion + tokenPtr = parsePtr->tokenPtr; + Tcl_Size build; + int concat; + for (concat = 0, build = 0, i = 0; i < numWords; i++) { + if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD && build > 0) { + OP4( LIST, build); + if (concat) { + OP( LIST_CONCAT); + } + build = 0; + concat = 1; + } + PUSH_TOKEN( tokenPtr, i); + if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { + if (concat) { + OP( LIST_CONCAT); + } else { + concat = 1; + } + } else { + build++; + } + if (build > LIST_CONCAT_THRESHOLD) { + OP4( LIST, build); + if (concat) { + OP( LIST_CONCAT); + } + build = 0; + concat = 1; + } + tokenPtr = TokenAfter(tokenPtr); + } + if (build > 0) { + OP4( LIST, build); + if (concat) { + OP( LIST_CONCAT); + } + } + + // Invoke the underlying [next] implementation + INVOKE( TCLOO_NEXT_LIST); return TCL_OK; } @@ -2822,17 +3307,75 @@ TclCompileObjectNextToCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr = parsePtr->tokenPtr; - int i; + Tcl_Size i, numWords = parsePtr->numWords; - if ((int)parsePtr->numWords < 2 || (int)parsePtr->numWords > 255) { + if (numWords < 2) { return TCL_ERROR; + } else if (numWords > UINT_MAX) { + // Very large number of words anyway + goto issueExpanded; + } + + // Check for expansion + for (i=0 ; i<numWords ; i++) { + if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { + goto issueExpanded; + } + tokenPtr = TokenAfter(tokenPtr); } - for (i=0 ; i<(int)parsePtr->numWords ; i++) { - CompileWord(envPtr, tokenPtr, interp, i); + // Simple instruction issue + tokenPtr = parsePtr->tokenPtr; + for (i=0 ; i<numWords ; i++) { + PUSH_TOKEN( tokenPtr, i); + tokenPtr = TokenAfter(tokenPtr); + } + INVOKE4( TCLOO_NEXT_CLASS, i); + return TCL_OK; + + issueExpanded: + // Concatenate all arguments into a list; handles expansion + tokenPtr = parsePtr->tokenPtr; + Tcl_Size build; + int concat; + for (concat = 0, build = 0, i = 0; i < numWords; i++) { + if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD && build > 0) { + OP4( LIST, build); + if (concat) { + OP( LIST_CONCAT); + } + build = 0; + concat = 1; + } + PUSH_TOKEN( tokenPtr, i); + if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { + if (concat) { + OP( LIST_CONCAT); + } else { + concat = 1; + } + } else { + build++; + } + if (build > LIST_CONCAT_THRESHOLD) { + OP4( LIST, build); + if (concat) { + OP( LIST_CONCAT); + } + build = 0; + concat = 1; + } tokenPtr = TokenAfter(tokenPtr); } - TclEmitInstInt1( INST_TCLOO_NEXT_CLASS, i, envPtr); + if (build > 0) { + OP4( LIST, build); + if (concat) { + OP( LIST_CONCAT); + } + } + + // Invoke the underlying [nextto] implementation + INVOKE( TCLOO_NEXT_CLASS_LIST); return TCL_OK; } @@ -2845,24 +3388,20 @@ TclCompileObjectSelfCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { /* - * We only handle [self] and [self object] (which is the same operation). - * These are the only very common operations on [self] for which - * bytecoding is at all reasonable. + * We only handle [self], [self object] (which is the same operation) and + * [self namespace]. These are the only very common operations on [self] + * for which bytecoding is at all reasonable, with [self namespace] being + * just because it is convenient with ops we already have. */ if (parsePtr->numWords == 1) { goto compileSelfObject; } else if (parsePtr->numWords == 2) { - Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr), *subcmd; - - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size==0) { - return TCL_ERROR; - } + const Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); - subcmd = tokenPtr + 1; - if (strncmp(subcmd->start, "object", subcmd->size) == 0) { + if (IS_TOKEN_PREFIX(tokenPtr, 1, "object")) { goto compileSelfObject; - } else if (strncmp(subcmd->start, "namespace", subcmd->size) == 0) { + } else if (IS_TOKEN_PREFIX(tokenPtr, 1, "namespace")) { goto compileSelfNamespace; } } @@ -2879,7 +3418,7 @@ TclCompileObjectSelfCmd( * This delegates the entire problem to a single opcode. */ - TclEmitOpcode( INST_TCLOO_SELF, envPtr); + OP( TCLOO_SELF); return TCL_OK; compileSelfNamespace: @@ -2892,9 +3431,9 @@ TclCompileObjectSelfCmd( * avoids creating another opcode, so that's all good! */ - TclEmitOpcode( INST_TCLOO_SELF, envPtr); - TclEmitOpcode( INST_POP, envPtr); - TclEmitOpcode( INST_NS_CURRENT, envPtr); + OP( TCLOO_SELF); + OP( POP); + OP( NS_CURRENT); return TCL_OK; } diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 5e27796..b32052e 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -9,7 +9,7 @@ * Copyright © 1997-1998 Sun Microsystems, Inc. * Copyright © 2001 Kevin B. Kenny. All rights reserved. * Copyright © 2002 ActiveState Corporation. - * Copyright © 2004-2010 Donal K. Fellows. + * Copyright © 2004-2025 Donal K. Fellows. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -20,6 +20,29 @@ #include "tclStringTrim.h" /* + * Information about a single arm for [switch]. Used in an array to pass + * information to the code-issuer functions. + */ +typedef struct SwitchArmInfo { + Tcl_Token *valueToken; // The value to match for the arm. + Tcl_Token *bodyToken; // The body of an arm; NULL if fall-through. + Tcl_Size bodyLine; // The line that the body starts on. + Tcl_Size *bodyContLines; // Continuations within the body. +} SwitchArmInfo; + +/* + * Information about a single handler for [try]. Used in an array to pass + * information to the code-issuer functions. + */ +typedef struct TryHandlerInfo { + Tcl_Token *tokenPtr; // The handler body, or NULL for none. + Tcl_Obj *matchClause; // The [trap] clause, or NULL for none. + int matchCode; // The result code. + Tcl_LVTIndex resultVar; // The result variable index, or TCL_INDEX_NONE + Tcl_LVTIndex optionVar; // The option variable index, or TCL_INDEX_NONE +} TryHandlerInfo; + +/* * Prototypes for procedures defined later in this file: */ @@ -27,6 +50,9 @@ static AuxDataDupProc DupJumptableInfo; static AuxDataFreeProc FreeJumptableInfo; static AuxDataPrintProc PrintJumptableInfo; static AuxDataPrintProc DisassembleJumptableInfo; +static AuxDataDupProc DupJumptableNumInfo; +static AuxDataPrintProc PrintJumptableNumInfo; +static AuxDataPrintProc DisassembleJumptableNumInfo; static int CompileAssociativeBinaryOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, const char *identity, int instruction, CompileEnv *envPtr); @@ -41,22 +67,24 @@ static int CompileUnaryOpCmd(Tcl_Interp *interp, CompileEnv *envPtr); static void IssueSwitchChainedTests(Tcl_Interp *interp, CompileEnv *envPtr, int mode, int noCase, - Tcl_Size numWords, Tcl_Token **bodyToken, - Tcl_Size *bodyLines, Tcl_Size **bodyNext); + Tcl_Size numArms, SwitchArmInfo *arms); static void IssueSwitchJumpTable(Tcl_Interp *interp, - CompileEnv *envPtr, int numWords, - Tcl_Token **bodyToken, Tcl_Size *bodyLines, - Tcl_Size **bodyContLines); + CompileEnv *envPtr, int noCase, Tcl_Size numArms, + SwitchArmInfo *arms); static int IssueTryClausesInstructions(Tcl_Interp *interp, CompileEnv *envPtr, Tcl_Token *bodyToken, - int numHandlers, int *matchCodes, - Tcl_Obj **matchClauses, int *resultVarIndices, - int *optionVarIndices, Tcl_Token **handlerTokens); + Tcl_Size numHandlers, TryHandlerInfo *handlers); +static int IssueTryTraplessClausesInstructions(Tcl_Interp *interp, + CompileEnv *envPtr, Tcl_Token *bodyToken, + Tcl_Size numHandlers, TryHandlerInfo *handlers); static int IssueTryClausesFinallyInstructions(Tcl_Interp *interp, CompileEnv *envPtr, Tcl_Token *bodyToken, - int numHandlers, int *matchCodes, - Tcl_Obj **matchClauses, int *resultVarIndices, - int *optionVarIndices, Tcl_Token **handlerTokens, + Tcl_Size numHandlers, TryHandlerInfo *handlers, + Tcl_Token *finallyToken); +static int IssueTryTraplessClausesFinallyInstructions( + Tcl_Interp *interp, CompileEnv *envPtr, + Tcl_Token *bodyToken, + Tcl_Size numHandlers, TryHandlerInfo *handlers, Tcl_Token *finallyToken); static int IssueTryFinallyInstructions(Tcl_Interp *interp, CompileEnv *envPtr, Tcl_Token *bodyToken, @@ -74,33 +102,13 @@ const AuxDataType tclJumptableInfoType = { DisassembleJumptableInfo /* disassembleProc */ }; -/* - * Shorthand macros for instruction issuing. - */ - -#define OP(name) TclEmitOpcode(INST_##name, envPtr) -#define OP1(name,val) TclEmitInstInt1(INST_##name,(val),envPtr) -#define OP4(name,val) TclEmitInstInt4(INST_##name,(val),envPtr) -#define OP14(name,val1,val2) \ - TclEmitInstInt1(INST_##name,(val1),envPtr);TclEmitInt4((val2),envPtr) -#define OP44(name,val1,val2) \ - TclEmitInstInt4(INST_##name,(val1),envPtr);TclEmitInt4((val2),envPtr) -#define PUSH(str) \ - PushStringLiteral(envPtr, str) -#define JUMP4(name,var) \ - (var) = CurrentOffset(envPtr);TclEmitInstInt4(INST_##name##4,0,envPtr) -#define FIXJUMP4(var) \ - TclStoreInt4AtPtr(CurrentOffset(envPtr)-(var),envPtr->codeStart+(var)+1) -#define JUMP1(name,var) \ - (var) = CurrentOffset(envPtr);TclEmitInstInt1(INST_##name##1,0,envPtr) -#define FIXJUMP1(var) \ - TclStoreInt1AtPtr(CurrentOffset(envPtr)-(var),envPtr->codeStart+(var)+1) -#define LOAD(idx) \ - if ((idx)<256) {OP1(LOAD_SCALAR1,(idx));} else {OP4(LOAD_SCALAR4,(idx));} -#define STORE(idx) \ - if ((idx)<256) {OP1(STORE_SCALAR1,(idx));} else {OP4(STORE_SCALAR4,(idx));} -#define INVOKE(name) \ - TclEmitInvoke(envPtr,INST_##name) +const AuxDataType tclJumptableNumericInfoType = { + "JumptableNumInfo", /* name */ + DupJumptableNumInfo, /* dupProc */ + FreeJumptableInfo, /* freeProc */ + PrintJumptableNumInfo, /* printProc */ + DisassembleJumptableNumInfo /* disassembleProc */ +}; /* *---------------------------------------------------------------------- @@ -130,9 +138,10 @@ TclCompileSetCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr, *valueTokenPtr; - int isAssignment, isScalar, localIndex, numWords; + int isAssignment, isScalar; + Tcl_Size numWords = parsePtr->numWords; + Tcl_LVTIndex localIndex; - numWords = parsePtr->numWords; if ((numWords != 2) && (numWords != 3)) { return TCL_ERROR; } @@ -147,8 +156,7 @@ TclCompileSetCmd( */ varTokenPtr = TokenAfter(parsePtr->tokenPtr); - PushVarNameWord(interp, varTokenPtr, envPtr, 0, - &localIndex, &isScalar, 1); + PushVarNameWord(varTokenPtr, 0, &localIndex, &isScalar, 1); /* * If we are doing an assignment, push the new value. @@ -156,40 +164,42 @@ TclCompileSetCmd( if (isAssignment) { valueTokenPtr = TokenAfter(varTokenPtr); - CompileWord(envPtr, valueTokenPtr, interp, 2); + PUSH_TOKEN( valueTokenPtr, 2); } /* * Emit instructions to set/get the variable. */ - if (isScalar) { - if (localIndex < 0) { - TclEmitOpcode((isAssignment? - INST_STORE_STK : INST_LOAD_STK), envPtr); - } else if (localIndex <= 255) { - TclEmitInstInt1((isAssignment? - INST_STORE_SCALAR1 : INST_LOAD_SCALAR1), - localIndex, envPtr); + if (isScalar) { + if (localIndex < 0) { + if (isAssignment) { + OP( STORE_STK); } else { - TclEmitInstInt4((isAssignment? - INST_STORE_SCALAR4 : INST_LOAD_SCALAR4), - localIndex, envPtr); + OP( LOAD_STK); } } else { - if (localIndex < 0) { - TclEmitOpcode((isAssignment? - INST_STORE_ARRAY_STK : INST_LOAD_ARRAY_STK), envPtr); - } else if (localIndex <= 255) { - TclEmitInstInt1((isAssignment? - INST_STORE_ARRAY1 : INST_LOAD_ARRAY1), - localIndex, envPtr); + if (isAssignment) { + OP4( STORE_SCALAR, localIndex); } else { - TclEmitInstInt4((isAssignment? - INST_STORE_ARRAY4 : INST_LOAD_ARRAY4), - localIndex, envPtr); + OP4( LOAD_SCALAR, localIndex); } } + } else { + if (localIndex < 0) { + if (isAssignment) { + OP( STORE_ARRAY_STK); + } else { + OP( LOAD_ARRAY_STK); + } + } else { + if (isAssignment) { + OP4( STORE_ARRAY, localIndex); + } else { + OP4( LOAD_ARRAY, localIndex); + } + } + } return TCL_OK; } @@ -222,14 +232,15 @@ TclCompileStringCatCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ - int i, numWords = parsePtr->numWords, numArgs; + Tcl_Size i, numWords = parsePtr->numWords, numArgs; Tcl_Token *wordTokenPtr; Tcl_Obj *obj, *folded; + /* TODO: Consider support for compiling expanded args. */ /* Trivial case, no arg */ - if (numWords<2) { - PushStringLiteral(envPtr, ""); + if (numWords < 2) { + PUSH( ""); return TCL_OK; } @@ -244,41 +255,33 @@ TclCompileStringCatCmd( if (TclWordKnownAtCompileTime(wordTokenPtr, obj)) { if (folded) { Tcl_AppendObjToObj(folded, obj); - Tcl_DecrRefCount(obj); + Tcl_BounceRefCount(obj); } else { folded = obj; } } else { - Tcl_DecrRefCount(obj); + Tcl_BounceRefCount(obj); if (folded) { - Tcl_Size len; - const char *bytes = TclGetStringFromObj(folded, &len); - - PushLiteral(envPtr, bytes, len); - Tcl_DecrRefCount(folded); + PUSH_OBJ( folded); folded = NULL; - numArgs ++; + numArgs++; } - CompileWord(envPtr, wordTokenPtr, interp, i); - numArgs ++; + PUSH_TOKEN( wordTokenPtr, i); + numArgs++; if (numArgs >= 254) { /* 254 to take care of the possible +1 of "folded" above */ - TclEmitInstInt1(INST_STR_CONCAT1, numArgs, envPtr); + OP1( STR_CONCAT1, numArgs); numArgs = 1; /* concat pushes 1 obj, the result */ } } wordTokenPtr = TokenAfter(wordTokenPtr); } if (folded) { - Tcl_Size len; - const char *bytes = TclGetStringFromObj(folded, &len); - - PushLiteral(envPtr, bytes, len); - Tcl_DecrRefCount(folded); + PUSH_OBJ( folded); folded = NULL; - numArgs ++; + numArgs++; } if (numArgs > 1) { - TclEmitInstInt1(INST_STR_CONCAT1, numArgs, envPtr); + OP1( STR_CONCAT1, numArgs); } return TCL_OK; @@ -293,7 +296,7 @@ TclCompileStringCmpCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ - Tcl_Token *tokenPtr; + Tcl_Token *aTokenPtr, *bTokenPtr; /* * We don't support any flags; the bytecode isn't that sophisticated. @@ -307,11 +310,11 @@ TclCompileStringCmpCmd( * Push the two operands onto the stack and then the test. */ - tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 2); - TclEmitOpcode(INST_STR_CMP, envPtr); + aTokenPtr = TokenAfter(parsePtr->tokenPtr); + bTokenPtr = TokenAfter(aTokenPtr); + PUSH_TOKEN( aTokenPtr, 1); + PUSH_TOKEN( bTokenPtr, 2); + OP( STR_CMP); return TCL_OK; } @@ -324,7 +327,7 @@ TclCompileStringEqualCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ - Tcl_Token *tokenPtr; + Tcl_Token *aTokenPtr, *bTokenPtr; /* * We don't support any flags; the bytecode isn't that sophisticated. @@ -338,11 +341,11 @@ TclCompileStringEqualCmd( * Push the two operands onto the stack and then the test. */ - tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 2); - TclEmitOpcode(INST_STR_EQ, envPtr); + aTokenPtr = TokenAfter(parsePtr->tokenPtr); + bTokenPtr = TokenAfter(aTokenPtr); + PUSH_TOKEN( aTokenPtr, 1); + PUSH_TOKEN( bTokenPtr, 2); + OP( STR_EQ); return TCL_OK; } @@ -355,7 +358,7 @@ TclCompileStringFirstCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ - Tcl_Token *tokenPtr; + Tcl_Token *needleToken, *haystackToken; /* * We don't support any flags; the bytecode isn't that sophisticated. @@ -369,11 +372,11 @@ TclCompileStringFirstCmd( * Push the two operands onto the stack and then the test. */ - tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 2); - OP(STR_FIND); + needleToken = TokenAfter(parsePtr->tokenPtr); + haystackToken = TokenAfter(needleToken); + PUSH_TOKEN( needleToken, 1); + PUSH_TOKEN( haystackToken, 2); + OP( STR_FIND); return TCL_OK; } @@ -386,7 +389,7 @@ TclCompileStringLastCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ - Tcl_Token *tokenPtr; + Tcl_Token *needleToken, *haystackToken; /* * We don't support any flags; the bytecode isn't that sophisticated. @@ -400,11 +403,11 @@ TclCompileStringLastCmd( * Push the two operands onto the stack and then the test. */ - tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 2); - OP(STR_FIND_LAST); + needleToken = TokenAfter(parsePtr->tokenPtr); + haystackToken = TokenAfter(needleToken); + PUSH_TOKEN( needleToken, 1); + PUSH_TOKEN( haystackToken, 2); + OP( STR_FIND_LAST); return TCL_OK; } @@ -417,7 +420,7 @@ TclCompileStringIndexCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ - Tcl_Token *tokenPtr; + Tcl_Token *aTokenPtr, *bTokenPtr; if (parsePtr->numWords != 3) { return TCL_ERROR; @@ -427,11 +430,11 @@ TclCompileStringIndexCmd( * Push the two operands onto the stack and then the index operation. */ - tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 2); - TclEmitOpcode(INST_STR_INDEX, envPtr); + aTokenPtr = TokenAfter(parsePtr->tokenPtr); + bTokenPtr = TokenAfter(aTokenPtr); + PUSH_TOKEN( aTokenPtr, 1); + PUSH_TOKEN( bTokenPtr, 2); + OP( STR_INDEX); return TCL_OK; } @@ -444,48 +447,46 @@ TclCompileStringInsertCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ - Tcl_Token *tokenPtr; + Tcl_Token *strToken, *idxToken, *insToken; int idx; if (parsePtr->numWords != 4) { return TCL_ERROR; } - /* Compute and push the string in which to insert */ - tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); + strToken = TokenAfter(parsePtr->tokenPtr); /* See what can be discovered about index at compile time */ - tokenPtr = TokenAfter(tokenPtr); - if (TCL_OK != TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, + idxToken = TokenAfter(strToken); + if (TCL_OK != TclGetIndexFromToken(idxToken, TCL_INDEX_START, TCL_INDEX_END, &idx)) { /* Nothing useful knowable - cease compile; let it direct eval */ return TCL_ERROR; } - /* Compute and push the string to be inserted */ - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 3); + insToken = TokenAfter(idxToken); + PUSH_TOKEN( strToken, 1); + PUSH_TOKEN( insToken, 3); if (idx == (int)TCL_INDEX_START) { /* Prepend the insertion string */ - OP4( REVERSE, 2); - OP1( STR_CONCAT1, 2); + OP( SWAP); + OP1( STR_CONCAT1, 2); } else if (idx == (int)TCL_INDEX_END) { /* Append the insertion string */ - OP1( STR_CONCAT1, 2); + OP1( STR_CONCAT1, 2); } else { /* Prefix + insertion + suffix */ if (idx < (int)TCL_INDEX_END) { /* See comments in compiler for [linsert]. */ idx++; } - OP4( OVER, 1); - OP44( STR_RANGE_IMM, 0, idx-1); - OP4( REVERSE, 3); - OP44( STR_RANGE_IMM, idx, TCL_INDEX_END); - OP1( STR_CONCAT1, 3); + OP4( OVER, 1); + OP44( STR_RANGE_IMM, 0, idx - 1); + OP4( REVERSE, 3); + OP44( STR_RANGE_IMM, idx, TCL_INDEX_END); + OP1( STR_CONCAT1, 3); } return TCL_OK; @@ -518,7 +519,9 @@ TclCompileStringIsCmd( STR_IS_SPACE, STR_IS_TRUE, STR_IS_UPPER, STR_IS_WIDE, STR_IS_WORD, STR_IS_XDIGIT } t; - int range, allowEmpty = 0, end; + int allowEmpty = 0; + Tcl_ExceptionRange range; + Tcl_BytecodeLabel end; InstStringClassType strClassType; Tcl_Obj *isClass; @@ -537,12 +540,6 @@ TclCompileStringIsCmd( } Tcl_DecrRefCount(isClass); -#define GotLiteral(tokenPtr, word) \ - ((tokenPtr)->type == TCL_TOKEN_SIMPLE_WORD && \ - (tokenPtr)[1].size > 1 && \ - (tokenPtr)[1].start[0] == word[0] && \ - strncmp((tokenPtr)[1].start, (word), (tokenPtr)[1].size) == 0) - /* * Cannot handle the -failindex option at all, and that's the only legal * way to have more than 4 arguments. @@ -556,12 +553,11 @@ TclCompileStringIsCmd( if (parsePtr->numWords == 3) { allowEmpty = 1; } else { - if (!GotLiteral(tokenPtr, "-strict")) { + if (!IS_TOKEN_PREFIX(tokenPtr, 2, "-strict")) { return TCL_ERROR; } tokenPtr = TokenAfter(tokenPtr); } -#undef GotLiteral /* * Compile the code. There are several main classes of check here. @@ -572,7 +568,7 @@ TclCompileStringIsCmd( * 5. Lists */ - CompileWord(envPtr, tokenPtr, interp, (int)parsePtr->numWords-1); + PUSH_TOKEN( tokenPtr, parsePtr->numWords - 1); switch (t) { case STR_IS_ALNUM: @@ -615,69 +611,71 @@ TclCompileStringIsCmd( strClassType = STR_CLASS_XDIGIT; compileStrClass: if (allowEmpty) { - OP1( STR_CLASS, strClassType); + OP1( STR_CLASS, strClassType); } else { - int over, over2; - - OP( DUP); - OP1( STR_CLASS, strClassType); - JUMP1( JUMP_TRUE, over); - OP( POP); - PUSH( "0"); - JUMP1( JUMP, over2); - FIXJUMP1(over); - PUSH( ""); - OP( STR_NEQ); - FIXJUMP1(over2); + Tcl_BytecodeLabel over, over2; + + OP( DUP); + OP1( STR_CLASS, strClassType); + FWDJUMP( JUMP_TRUE, over); + OP( POP); + PUSH( "0"); + FWDJUMP( JUMP, over2); + FWDLABEL( over); + OP( IS_EMPTY); + OP( LNOT); + FWDLABEL( over2); } return TCL_OK; case STR_IS_BOOL: case STR_IS_FALSE: case STR_IS_TRUE: - OP( TRY_CVT_TO_BOOLEAN); + OP( TRY_CVT_TO_BOOLEAN); switch (t) { - int over, over2; + Tcl_BytecodeLabel over, over2; case STR_IS_BOOL: if (allowEmpty) { - JUMP1( JUMP_TRUE, over); - PUSH( ""); - OP( STR_EQ); - JUMP1( JUMP, over2); - FIXJUMP1(over); - OP( POP); - PUSH( "1"); - FIXJUMP1(over2); + FWDJUMP( JUMP_TRUE, over); + OP( IS_EMPTY); + FWDJUMP( JUMP, over2); + FWDLABEL(over); + OP( POP); + PUSH( "1"); + FWDLABEL(over2); } else { - OP4( REVERSE, 2); - OP( POP); + OP( SWAP); + OP( POP); } return TCL_OK; case STR_IS_TRUE: - JUMP1( JUMP_TRUE, over); + FWDJUMP( JUMP_TRUE, over); if (allowEmpty) { - PUSH( ""); - OP( STR_EQ); + OP( IS_EMPTY); } else { - OP( POP); - PUSH( "0"); + OP( POP); + PUSH( "0"); } - FIXJUMP1( over); - OP( LNOT); - OP( LNOT); + FWDJUMP( JUMP, over2); + FWDLABEL( over); + // Normalize the boolean value + OP( LNOT); + OP( LNOT); + FWDLABEL( over2); return TCL_OK; case STR_IS_FALSE: - JUMP1( JUMP_TRUE, over); + FWDJUMP( JUMP_TRUE, over); if (allowEmpty) { - PUSH( ""); - OP( STR_NEQ); + OP( IS_EMPTY); } else { - OP( POP); - PUSH( "1"); + OP( POP); + PUSH( "0"); } - FIXJUMP1( over); - OP( LNOT); + FWDJUMP( JUMP, over2); + FWDLABEL( over); + OP( LNOT); + FWDLABEL( over2); return TCL_OK; default: break; @@ -685,30 +683,29 @@ TclCompileStringIsCmd( break; case STR_IS_DOUBLE: { - int satisfied, isEmpty; + Tcl_BytecodeLabel satisfied, isEmpty; if (allowEmpty) { - OP( DUP); - PUSH( ""); - OP( STR_EQ); - JUMP1( JUMP_TRUE, isEmpty); - OP( NUM_TYPE); - JUMP1( JUMP_TRUE, satisfied); - PUSH( "0"); - JUMP1( JUMP, end); - FIXJUMP1( isEmpty); - OP( POP); - FIXJUMP1( satisfied); + OP( DUP); + OP( IS_EMPTY); + FWDJUMP( JUMP_TRUE, isEmpty); + OP( NUM_TYPE); + FWDJUMP( JUMP_TRUE, satisfied); + PUSH( "0"); + FWDJUMP( JUMP, end); + FWDLABEL( isEmpty); + OP( POP); + FWDLABEL( satisfied); } else { - OP( NUM_TYPE); - JUMP1( JUMP_TRUE, satisfied); - PUSH( "0"); - JUMP1( JUMP, end); - TclAdjustStackDepth(-1, envPtr); - FIXJUMP1( satisfied); + OP( NUM_TYPE); + FWDJUMP( JUMP_TRUE, satisfied); + PUSH( "0"); + FWDJUMP( JUMP, end); + STKDELTA(-1); + FWDLABEL( satisfied); } - PUSH( "1"); - FIXJUMP1( end); + PUSH( "1"); + FWDLABEL( end); return TCL_OK; } @@ -716,67 +713,66 @@ TclCompileStringIsCmd( case STR_IS_WIDE: case STR_IS_ENTIER: if (allowEmpty) { - int testNumType; - - OP( DUP); - OP( NUM_TYPE); - OP( DUP); - JUMP1( JUMP_TRUE, testNumType); - OP( POP); - PUSH( ""); - OP( STR_EQ); - JUMP1( JUMP, end); - TclAdjustStackDepth(1, envPtr); - FIXJUMP1( testNumType); - OP4( REVERSE, 2); - OP( POP); + Tcl_BytecodeLabel testNumType; + + OP( DUP); + OP( NUM_TYPE); + OP( DUP); + FWDJUMP( JUMP_TRUE, testNumType); + OP( POP); + OP( IS_EMPTY); + FWDJUMP( JUMP, end); + STKDELTA(+1); + FWDLABEL( testNumType); + OP( SWAP); + OP( POP); } else { - OP( NUM_TYPE); - OP( DUP); - JUMP1( JUMP_FALSE, end); + OP( NUM_TYPE); + OP( DUP); + FWDJUMP( JUMP_FALSE, end); } switch (t) { case STR_IS_WIDE: - PUSH( "2"); - OP( LE); + PUSH( "2"); + OP( LE); break; case STR_IS_INT: case STR_IS_ENTIER: - PUSH( "3"); - OP( LE); + PUSH( "3"); + OP( LE); break; default: break; } - FIXJUMP1( end); + FWDLABEL( end); return TCL_OK; case STR_IS_DICT: - range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); - OP4( BEGIN_CATCH4, range); - ExceptionRangeStarts(envPtr, range); - OP( DUP); - OP( DICT_VERIFY); - ExceptionRangeEnds(envPtr, range); - ExceptionRangeTarget(envPtr, range, catchOffset); - OP( POP); - OP( PUSH_RETURN_CODE); - OP( END_CATCH); - OP( LNOT); + range = MAKE_CATCH_RANGE(); + OP4( BEGIN_CATCH, range); + OP( DUP); + CATCH_RANGE(range) { + OP( DICT_VERIFY); + } + CATCH_TARGET( range); + OP( POP); + OP( PUSH_RETURN_CODE); + OP( END_CATCH); + OP( LNOT); return TCL_OK; case STR_IS_LIST: - range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); - OP4( BEGIN_CATCH4, range); - ExceptionRangeStarts(envPtr, range); - OP( DUP); - OP( LIST_LENGTH); - OP( POP); - ExceptionRangeEnds(envPtr, range); - ExceptionRangeTarget(envPtr, range, catchOffset); - OP( POP); - OP( PUSH_RETURN_CODE); - OP( END_CATCH); - OP( LNOT); + range = MAKE_CATCH_RANGE(); + OP4( BEGIN_CATCH, range); + OP( DUP); + CATCH_RANGE(range) { + OP( LIST_LENGTH); + } + OP( POP); + CATCH_TARGET( range); + OP( POP); + OP( PUSH_RETURN_CODE); + OP( END_CATCH); + OP( LNOT); return TCL_OK; } @@ -794,11 +790,10 @@ TclCompileStringMatchCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - size_t length; - int i, exactMatch = 0, nocase = 0; - const char *str; + int exactMatch = 0, nocase = 0; + Tcl_Size i, numWords = parsePtr->numWords; - if (parsePtr->numWords < 3 || parsePtr->numWords > 4) { + if (numWords < 3 || numWords > 4) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -807,13 +802,8 @@ TclCompileStringMatchCmd( * Check if we have a -nocase flag. */ - if (parsePtr->numWords == 4) { - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); - } - str = tokenPtr[1].start; - length = tokenPtr[1].size; - if ((length <= 1) || strncmp(str, "-nocase", length)) { + if (numWords == 4) { + if (!IS_TOKEN_PREFIX(tokenPtr, 2, "-nocase")) { /* * Fail at run time, not in compilation. */ @@ -829,27 +819,18 @@ TclCompileStringMatchCmd( */ for (i = 0; i < 2; i++) { - if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - str = tokenPtr[1].start; - length = tokenPtr[1].size; - if (!nocase && (i == 0)) { - /* - * Trivial matches can be done by 'string equal'. If -nocase - * was specified, we can't do this because INST_STR_EQ has no - * support for nocase. - */ - - Tcl_Obj *copy = Tcl_NewStringObj(str, length); + if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD && !nocase && (i == 0)) { + /* + * Trivial matches can be done by 'string equal'. If -nocase was + * specified, we can't do this because INST_STR_EQ has no support + * for nocase. + */ - Tcl_IncrRefCount(copy); - exactMatch = TclMatchIsTrivial(TclGetString(copy)); - TclDecrRefCount(copy); - } - PushLiteral(envPtr, str, length); - } else { - SetLineInformation(i+1+nocase); - CompileTokens(envPtr, tokenPtr, interp); + Tcl_Obj *copy = TokenToObj(tokenPtr); + exactMatch = TclMatchIsTrivial(TclGetString(copy)); + Tcl_BounceRefCount(copy); } + PUSH_TOKEN( tokenPtr, i + 1 + nocase); tokenPtr = TokenAfter(tokenPtr); } @@ -858,9 +839,9 @@ TclCompileStringMatchCmd( */ if (exactMatch) { - TclEmitOpcode(INST_STR_EQ, envPtr); + OP( STR_EQ); } else { - TclEmitInstInt1(INST_STR_MATCH, nocase, envPtr); + OP1( STR_MATCH, nocase); } return TCL_OK; } @@ -890,15 +871,12 @@ TclCompileStringLenCmd( * byte) length. */ - char buf[TCL_INTEGER_SPACE]; - size_t len = Tcl_GetCharLength(objPtr); - - len = snprintf(buf, sizeof(buf), "%" TCL_Z_MODIFIER "u", len); - PushLiteral(envPtr, buf, len); + Tcl_Obj *objLen = Tcl_NewWideUIntObj(Tcl_GetCharLength(objPtr)); + PUSH_OBJ( objLen); } else { SetLineInformation(1); CompileTokens(envPtr, tokenPtr, interp); - TclEmitOpcode(INST_STR_LEN, envPtr); + OP( STR_LEN); } TclDecrRefCount(objPtr); return TCL_OK; @@ -916,8 +894,7 @@ TclCompileStringMapCmd( DefineLineInformation; /* TIP #280 */ Tcl_Token *mapTokenPtr, *stringTokenPtr; Tcl_Obj *mapObj, **objv; - const char *bytes; - Tcl_Size len, slen; + Tcl_Size len; /* * We only handle the case: @@ -953,15 +930,13 @@ TclCompileStringMapCmd( * correct semantics for mapping. */ - bytes = TclGetStringFromObj(objv[0], &slen); - if (slen == 0) { - CompileWord(envPtr, stringTokenPtr, interp, 2); + if (!TclGetString(objv[0])[0]) { + PUSH_TOKEN( stringTokenPtr, 2); } else { - PushLiteral(envPtr, bytes, slen); - bytes = TclGetStringFromObj(objv[1], &slen); - PushLiteral(envPtr, bytes, slen); - CompileWord(envPtr, stringTokenPtr, interp, 2); - OP(STR_MAP); + PUSH_OBJ( objv[0]); + PUSH_OBJ( objv[1]); + PUSH_TOKEN( stringTokenPtr, 2); + OP( STR_MAP); } Tcl_DecrRefCount(mapObj); return TCL_OK; @@ -987,7 +962,7 @@ TclCompileStringRangeCmd( toTokenPtr = TokenAfter(fromTokenPtr); /* Every path must push the string argument */ - CompileWord(envPtr, stringTokenPtr, interp, 1); + PUSH_TOKEN( stringTokenPtr, 1); /* * Parse the two indices. @@ -1004,8 +979,8 @@ TclCompileStringRangeCmd( if (idx1 == (int)TCL_INDEX_NONE) { /* [string range $s end+1 $last] must be empty string */ - OP( POP); - PUSH( ""); + OP( POP); + PUSH( ""); return TCL_OK; } @@ -1019,8 +994,8 @@ TclCompileStringRangeCmd( */ if (idx2 == (int)TCL_INDEX_NONE) { /* [string range $s $first -1] must be empty string */ - OP( POP); - PUSH( ""); + OP( POP); + PUSH( ""); return TCL_OK; } @@ -1028,7 +1003,7 @@ TclCompileStringRangeCmd( * Push the operand onto the stack and then the substring operation. */ - OP44( STR_RANGE_IMM, idx1, idx2); + OP44( STR_RANGE_IMM, idx1, idx2); return TCL_OK; /* @@ -1036,9 +1011,9 @@ TclCompileStringRangeCmd( */ nonConstantIndices: - CompileWord(envPtr, fromTokenPtr, interp, 2); - CompileWord(envPtr, toTokenPtr, interp, 3); - OP( STR_RANGE); + PUSH_TOKEN( fromTokenPtr, 2); + PUSH_TOKEN( toTokenPtr, 3); + OP( STR_RANGE); return TCL_OK; } @@ -1054,13 +1029,13 @@ TclCompileStringReplaceCmd( Tcl_Token *tokenPtr, *valueTokenPtr; int first, last; - if ((int)parsePtr->numWords < 4 || (int)parsePtr->numWords > 5) { + if (parsePtr->numWords < 4 || parsePtr->numWords > 5) { return TCL_ERROR; } /* Bytecode to compute/push string argument being replaced */ valueTokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, valueTokenPtr, interp, 1); + PUSH_TOKEN( valueTokenPtr, 1); /* * Check for first index known and useful at compile time. @@ -1121,77 +1096,76 @@ TclCompileStringReplaceCmd( && (last < first))) { /* Know (last < first) */ if (parsePtr->numWords == 5) { tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 4); - OP( POP); /* Pop newString */ + PUSH_TOKEN( tokenPtr, 4); + OP( POP); /* Pop newString */ } /* Original string argument now on TOS as result */ return TCL_OK; } if (parsePtr->numWords == 5) { - /* - * When we have a string replacement, we have to take care about - * not replacing empty substrings that [string replace] promises - * not to replace - * - * The remaining index values might be suitable for conventional - * string replacement, but only if they cannot possibly meet the - * conditions described above at runtime. If there's a chance they - * might, we would have to emit bytecode to check and at that point - * we're paying more in bytecode execution time than would make - * things worthwhile. Trouble is we are very limited in - * how much we can detect that at compile time. After decoding, - * we need, first: - * - * (first <= end) - * - * The encoded indices (first <= TCL_INDEX END) and - * (first == TCL_INDEX_NONE) always meets this condition, but - * any other encoded first index has some list for which it fails. - * - * We also need, second: - * - * (last >= 0) - * - * The encoded index (last >= TCL_INDEX_START) always meet this - * condition but any other encoded last index has some list for - * which it fails. - * - * Finally we need, third: - * - * (first <= last) - * - * Considered in combination with the constraints we already have, - * we see that we can proceed when (first == TCL_INDEX_NONE). - * These also permit simplification of the prefix|replace|suffix - * construction. The other constraints, though, interfere with - * getting a guarantee that first <= last. - */ + /* + * When we have a string replacement, we have to take care about + * not replacing empty substrings that [string replace] promises + * not to replace + * + * The remaining index values might be suitable for conventional + * string replacement, but only if they cannot possibly meet the + * conditions described above at runtime. If there's a chance they + * might, we would have to emit bytecode to check and at that point + * we're paying more in bytecode execution time than would make + * things worthwhile. Trouble is we are very limited in + * how much we can detect that at compile time. After decoding, + * we need, first: + * + * (first <= end) + * + * The encoded indices (first <= TCL_INDEX END) and + * (first == TCL_INDEX_NONE) always meets this condition, but + * any other encoded first index has some list for which it fails. + * + * We also need, second: + * + * (last >= 0) + * + * The encoded index (last >= TCL_INDEX_START) always meet this + * condition but any other encoded last index has some list for + * which it fails. + * + * Finally we need, third: + * + * (first <= last) + * + * Considered in combination with the constraints we already have, + * we see that we can proceed when (first == TCL_INDEX_NONE). + * These also permit simplification of the prefix|replace|suffix + * construction. The other constraints, though, interfere with + * getting a guarantee that first <= last. + */ - if ((first == (int)TCL_INDEX_START) && (last >= (int)TCL_INDEX_START)) { - /* empty prefix */ - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 4); - OP4( REVERSE, 2); - if (last == INT_MAX) { - OP( POP); /* Pop original */ - } else { - OP44( STR_RANGE_IMM, last + 1, (int)TCL_INDEX_END); - OP1( STR_CONCAT1, 2); + if ((first == (int)TCL_INDEX_START) && (last >= (int)TCL_INDEX_START)) { + /* empty prefix */ + tokenPtr = TokenAfter(tokenPtr); + PUSH_TOKEN( tokenPtr, 4); + OP( SWAP); + if (last == INT_MAX) { + OP( POP); /* Pop original */ + } else { + OP44( STR_RANGE_IMM, last + 1, (int)TCL_INDEX_END); + OP1( STR_CONCAT1, 2); + } + return TCL_OK; } - return TCL_OK; - } - if ((last == (int)TCL_INDEX_NONE) && (first <= (int)TCL_INDEX_END)) { - OP44( STR_RANGE_IMM, 0, first-1); - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 4); - OP1( STR_CONCAT1, 2); - return TCL_OK; - } + if ((last == (int)TCL_INDEX_NONE) && (first <= (int)TCL_INDEX_END)) { + OP44( STR_RANGE_IMM, 0, first-1); + tokenPtr = TokenAfter(tokenPtr); + PUSH_TOKEN( tokenPtr, 4); + OP1( STR_CONCAT1, 2); + return TCL_OK; + } /* FLOW THROUGH TO genericReplace */ - } else { /* * When we have no replacement string to worry about, we may @@ -1204,40 +1178,40 @@ TclCompileStringReplaceCmd( if (last == (int)TCL_INDEX_END) { /* empty suffix too => empty result */ - OP( POP); /* Pop original */ - PUSH ( ""); + OP( POP); /* Pop original */ + PUSH( ""); return TCL_OK; } - OP44( STR_RANGE_IMM, last + 1, (int)TCL_INDEX_END); + OP44( STR_RANGE_IMM, last + 1, TCL_INDEX_END); return TCL_OK; } else { if (last == (int)TCL_INDEX_END) { /* empty suffix - build prefix only */ - OP44( STR_RANGE_IMM, 0, first-1); + OP44( STR_RANGE_IMM, 0, first - 1); return TCL_OK; } - OP( DUP); - OP44( STR_RANGE_IMM, 0, first-1); - OP4( REVERSE, 2); - OP44( STR_RANGE_IMM, last + 1, (int)TCL_INDEX_END); - OP1( STR_CONCAT1, 2); + OP( DUP); + OP44( STR_RANGE_IMM, 0, first - 1); + OP( SWAP); + OP44( STR_RANGE_IMM, last + 1, TCL_INDEX_END); + OP1( STR_CONCAT1, 2); return TCL_OK; } } - genericReplace: - tokenPtr = TokenAfter(valueTokenPtr); - CompileWord(envPtr, tokenPtr, interp, 2); + genericReplace: + tokenPtr = TokenAfter(valueTokenPtr); + PUSH_TOKEN( tokenPtr, 2); + tokenPtr = TokenAfter(tokenPtr); + PUSH_TOKEN( tokenPtr, 3); + if (parsePtr->numWords == 5) { tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 3); - if (parsePtr->numWords == 5) { - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 4); - } else { - PUSH( ""); - } - OP( STR_REPLACE); - return TCL_OK; + PUSH_TOKEN( tokenPtr, 4); + } else { + PUSH( ""); + } + OP( STR_REPLACE); + return TCL_OK; } int @@ -1256,14 +1230,14 @@ TclCompileStringTrimLCmd( } tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); + PUSH_TOKEN( tokenPtr, 1); if (parsePtr->numWords == 3) { tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 2); + PUSH_TOKEN( tokenPtr, 2); } else { - PushLiteral(envPtr, tclDefaultTrimSet, strlen(tclDefaultTrimSet)); + PUSH_STRING( tclDefaultTrimSet); } - OP( STR_TRIM_LEFT); + OP( STR_TRIM_LEFT); return TCL_OK; } @@ -1283,14 +1257,14 @@ TclCompileStringTrimRCmd( } tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); + PUSH_TOKEN( tokenPtr, 1); if (parsePtr->numWords == 3) { tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 2); + PUSH_TOKEN( tokenPtr, 2); } else { - PushLiteral(envPtr, tclDefaultTrimSet, strlen(tclDefaultTrimSet)); + PUSH_STRING( tclDefaultTrimSet); } - OP( STR_TRIM_RIGHT); + OP( STR_TRIM_RIGHT); return TCL_OK; } @@ -1310,14 +1284,14 @@ TclCompileStringTrimCmd( } tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); + PUSH_TOKEN( tokenPtr, 1); if (parsePtr->numWords == 3) { tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 2); + PUSH_TOKEN( tokenPtr, 2); } else { - PushLiteral(envPtr, tclDefaultTrimSet, strlen(tclDefaultTrimSet)); + PUSH_STRING( tclDefaultTrimSet); } - OP( STR_TRIM); + OP( STR_TRIM); return TCL_OK; } @@ -1338,8 +1312,8 @@ TclCompileStringToUpperCmd( } tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); - OP( STR_UPPER); + PUSH_TOKEN( tokenPtr, 1); + OP( STR_UPPER); return TCL_OK; } @@ -1360,8 +1334,8 @@ TclCompileStringToLowerCmd( } tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); - OP( STR_LOWER); + PUSH_TOKEN( tokenPtr, 1); + OP( STR_LOWER); return TCL_OK; } @@ -1382,8 +1356,8 @@ TclCompileStringToTitleCmd( } tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); - OP( STR_TITLE); + PUSH_TOKEN( tokenPtr, 1); + OP( STR_TITLE); return TCL_OK; } @@ -1451,20 +1425,20 @@ TclCompileSubstCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ - int numArgs = parsePtr->numWords - 1; - int numOpts = numArgs - 1; - int objc, flags = TCL_SUBST_ALL; + Tcl_Size numArgs = parsePtr->numWords - 1; + Tcl_Size objc, numOpts = numArgs - 1; + int flags = TCL_SUBST_ALL; Tcl_Obj **objv/*, *toSubst = NULL*/; Tcl_Token *wordTokenPtr = TokenAfter(parsePtr->tokenPtr); int code = TCL_ERROR; - if (numArgs == 0) { + if (numArgs == 0 || numArgs > UINT_MAX) { return TCL_ERROR; } - objv = (Tcl_Obj **)TclStackAlloc(interp, /*numArgs*/ numOpts * sizeof(Tcl_Obj *)); + objv = (Tcl_Obj **)TclStackAlloc(interp, numOpts * sizeof(Tcl_Obj *)); - for (objc = 0; objc < /*numArgs*/ numOpts; objc++) { + for (objc = 0; objc < numOpts; objc++) { TclNewObj(objv[objc]); Tcl_IncrRefCount(objv[objc]); if (!TclWordKnownAtCompileTime(wordTokenPtr, objv[objc])) { @@ -1482,10 +1456,10 @@ TclCompileSubstCmd( */ /* TODO: Figure out expansion to cover WordKnownAtCompileTime - * The difficulty is that WKACT makes a copy, and if TclSubstParse - * below parses the copy of the original source string, some deep - * parts of the compile machinery get upset. They want all pointers - * stored in Tcl_Tokens to point back to the same original string. + * The difficulty is that WKACT makes a copy, and if TclSubstParse + * below parses the copy of the original source string, some deep + * parts of the compile machinery get upset. They want all pointers + * stored in Tcl_Tokens to point back to the same original string. */ if (wordTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { code = TclSubstOptions(NULL, numOpts, objv, &flags); @@ -1502,7 +1476,7 @@ TclCompileSubstCmd( SetLineInformation(numArgs); TclSubstCompile(interp, wordTokenPtr[1].start, wordTokenPtr[1].size, - flags, mapPtr->loc[eclIndex].line[numArgs], envPtr); + flags, ExtCmdLocation.line[numArgs], envPtr); /* TclDecrRefCount(toSubst);*/ return TCL_OK; @@ -1514,12 +1488,13 @@ TclSubstCompile( const char *bytes, Tcl_Size numBytes, int flags, - Tcl_Size line, + int line, CompileEnv *envPtr) { Tcl_Token *endTokenPtr, *tokenPtr; - int breakOffset = 0, count = 0; - Tcl_Size bline = line; + Tcl_BytecodeLabel breakOffset = 0; + Tcl_Size count = 0; + int bline = line; Tcl_Parse parse; Tcl_InterpState state = NULL; @@ -1538,23 +1513,22 @@ TclSubstCompile( tokenPtr = parse.tokenPtr; if (tokenPtr->type != TCL_TOKEN_TEXT && tokenPtr->type != TCL_TOKEN_BS) { - PUSH(""); + PUSH( ""); count++; } for (endTokenPtr = tokenPtr + parse.numTokens; tokenPtr < endTokenPtr; tokenPtr = TokenAfter(tokenPtr)) { Tcl_Size length; - int literal, catchRange, breakJump; + Tcl_ExceptionRange catchRange; + Tcl_BytecodeLabel end, haveOk, haveOther, tableBase; + JumptableNumInfo *retCodeTable; + Tcl_AuxDataRef tableIdx; char buf[4] = ""; - JumpFixup startFixup, okFixup, returnFixup, breakFixup; - JumpFixup continueFixup, otherFixup, endFixup; switch (tokenPtr->type) { case TCL_TOKEN_TEXT: - literal = TclRegisterLiteral(envPtr, - tokenPtr->start, tokenPtr->size, 0); - TclEmitPush(literal, envPtr); + PushLiteral(envPtr, tokenPtr->start, tokenPtr->size); TclAdvanceLines(&bline, tokenPtr->start, tokenPtr->start + tokenPtr->size); count++; @@ -1562,8 +1536,7 @@ TclSubstCompile( case TCL_TOKEN_BS: length = TclParseBackslash(tokenPtr->start, tokenPtr->size, NULL, buf); - literal = TclRegisterLiteral(envPtr, buf, length, 0); - TclEmitPush(literal, envPtr); + PushLiteral(envPtr, buf, length); count++; continue; case TCL_TOKEN_VARIABLE: @@ -1607,139 +1580,97 @@ TclSubstCompile( } if (breakOffset == 0) { + Tcl_BytecodeLabel start; /* Jump to the start (jump over the jump to end) */ - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &startFixup); + FWDJUMP( JUMP, start); /* Jump to the end (all BREAKs land here) */ - breakOffset = CurrentOffset(envPtr); - TclEmitInstInt4(INST_JUMP4, 0, envPtr); + FWDJUMP( JUMP, breakOffset); /* Start */ - if (TclFixupForwardJumpToHere(envPtr, &startFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad start jump distance %" TCL_Z_MODIFIER "d", - CurrentOffset(envPtr) - startFixup.codeOffset); - } + FWDLABEL( start); } envPtr->line = bline; - catchRange = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); - OP4( BEGIN_CATCH4, catchRange); - ExceptionRangeStarts(envPtr, catchRange); - - switch (tokenPtr->type) { - case TCL_TOKEN_COMMAND: - TclCompileScript(interp, tokenPtr->start+1, tokenPtr->size-2, - envPtr); - count++; - break; - case TCL_TOKEN_VARIABLE: - TclCompileVarSubst(interp, tokenPtr, envPtr); - count++; - break; - default: - Tcl_Panic("unexpected token type in TclCompileSubstCmd: %d", - tokenPtr->type); + catchRange = MAKE_CATCH_RANGE(); + OP4( BEGIN_CATCH, catchRange); + CATCH_RANGE(catchRange) { + switch (tokenPtr->type) { + case TCL_TOKEN_COMMAND: + TclCompileScript(interp, tokenPtr->start+1, tokenPtr->size-2, + envPtr); + count++; + break; + case TCL_TOKEN_VARIABLE: + TclCompileVarSubst(interp, tokenPtr, envPtr); + count++; + break; + default: + Tcl_Panic("unexpected token type in TclCompileSubstCmd: %d", + tokenPtr->type); + } } - ExceptionRangeEnds(envPtr, catchRange); - /* Substitution produced TCL_OK */ - OP( END_CATCH); - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &okFixup); - TclAdjustStackDepth(-1, envPtr); + OP( END_CATCH); + FWDJUMP( JUMP, haveOk); + STKDELTA(-1); /* Exceptional return codes processed here */ - ExceptionRangeTarget(envPtr, catchRange, catchOffset); - OP( PUSH_RETURN_OPTIONS); - OP( PUSH_RESULT); - OP( PUSH_RETURN_CODE); - OP( END_CATCH); - OP( RETURN_CODE_BRANCH); - - /* ERROR -> reraise it; NB: can't require BREAK/CONTINUE handling */ - OP( RETURN_STK); - OP( NOP); - - /* RETURN */ - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &returnFixup); + CATCH_TARGET( catchRange); + OP( PUSH_RETURN_CODE); - /* BREAK */ - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &breakFixup); + retCodeTable = AllocJumptableNum(); + tableIdx = RegisterJumptableNum(retCodeTable, envPtr); + tableBase = CurrentOffset(envPtr); + OP4( JUMP_TABLE_NUM, tableIdx); + FWDJUMP( JUMP, haveOther); - /* CONTINUE */ - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &continueFixup); - - /* OTHER */ - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &otherFixup); + /* ERROR -> reraise it; NB: can't require BREAK/CONTINUE handling */ + CreateJumptableNumEntryToHere(retCodeTable, TCL_ERROR, tableBase); + OP( PUSH_RETURN_OPTIONS); + OP( PUSH_RESULT); + OP( END_CATCH); // catchRange + OP( RETURN_STK); + STKDELTA(-1); - TclAdjustStackDepth(1, envPtr); /* BREAK destination */ - if (TclFixupForwardJumpToHere(envPtr, &breakFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad break jump distance %" TCL_Z_MODIFIER "d", - CurrentOffset(envPtr) - breakFixup.codeOffset); - } - OP( POP); - OP( POP); - - breakJump = CurrentOffset(envPtr) - breakOffset; - if (breakJump > 127) { - OP4(JUMP4, -breakJump); - } else { - OP1(JUMP1, -breakJump); - } + CreateJumptableNumEntryToHere(retCodeTable, TCL_BREAK, tableBase); + OP( END_CATCH); // catchRange + BACKJUMP( JUMP, breakOffset); - TclAdjustStackDepth(2, envPtr); /* CONTINUE destination */ - if (TclFixupForwardJumpToHere(envPtr, &continueFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad continue jump distance %" TCL_Z_MODIFIER "d", - CurrentOffset(envPtr) - continueFixup.codeOffset); - } - OP( POP); - OP( POP); - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &endFixup); + CreateJumptableNumEntryToHere(retCodeTable, TCL_CONTINUE, tableBase); + OP( END_CATCH); // catchRange + FWDJUMP( JUMP, end); - TclAdjustStackDepth(2, envPtr); /* RETURN + other destination */ - if (TclFixupForwardJumpToHere(envPtr, &returnFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad return jump distance %" TCL_Z_MODIFIER "d", - CurrentOffset(envPtr) - returnFixup.codeOffset); - } - if (TclFixupForwardJumpToHere(envPtr, &otherFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad other jump distance %" TCL_Z_MODIFIER "d", - CurrentOffset(envPtr) - otherFixup.codeOffset); - } + FWDLABEL( haveOther); + OP( PUSH_RESULT); + OP( END_CATCH); // catchRange /* * Pull the result to top of stack, discard options dict. */ - OP4( REVERSE, 2); - OP( POP); - /* OK destination */ - if (TclFixupForwardJumpToHere(envPtr, &okFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad ok jump distance %" TCL_Z_MODIFIER "d", - CurrentOffset(envPtr) - okFixup.codeOffset); - } + FWDLABEL( haveOk); if (count > 1) { - OP1(STR_CONCAT1, count); + OP1( STR_CONCAT1, count); count = 1; } /* CONTINUE jump to here */ - if (TclFixupForwardJumpToHere(envPtr, &endFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad end jump distance %" TCL_Z_MODIFIER "d", - CurrentOffset(envPtr) - endFixup.codeOffset); - } + FWDLABEL( end); bline = envPtr->line; } while (count > 255) { - OP1( STR_CONCAT1, 255); + OP1( STR_CONCAT1, 255); count -= 254; } if (count > 1) { - OP1( STR_CONCAT1, count); + OP1( STR_CONCAT1, count); } Tcl_FreeParse(&parse); @@ -1747,19 +1678,61 @@ TclSubstCompile( if (state != NULL) { Tcl_RestoreInterpState(interp, state); TclCompileSyntaxError(interp, envPtr); - TclAdjustStackDepth(-1, envPtr); + STKDELTA(-1); } /* Final target of the multi-jump from all BREAKs */ if (breakOffset > 0) { - TclUpdateInstInt4AtPc(INST_JUMP4, CurrentOffset(envPtr) - breakOffset, - envPtr->codeStart + breakOffset); + FWDLABEL( breakOffset); } } /* *---------------------------------------------------------------------- * + * HasDefaultClause, IsFallthroughToken, IsFallthroughArm, + * SetSwitchLineInformation -- + * + * Support utilities for [switch] compilation. + * + *---------------------------------------------------------------------- + */ + +static inline int +HasDefaultClause( + Tcl_Size numArms, /* Number of arms describing things the + * switch can match against and bodies to + * execute when the match succeeds. */ + const SwitchArmInfo *arms) /* Array of body information. */ +{ + const Tcl_Token *finalValue = arms[numArms - 1].valueToken; + return (finalValue->size == 7) && !memcmp(finalValue->start, "default", 7); +} + +static inline int +IsFallthroughToken( + const Tcl_Token *tokenPtr) /* The token to check. */ +{ + return (tokenPtr->size == 1) && (tokenPtr->start[0] == '-'); +} + +static inline int +IsFallthroughArm( + const SwitchArmInfo *arm) /* Which arm to check. */ +{ + return arm->bodyToken == NULL; +} + +// SetLineInformation() for [switch] bodies +#define SetSwitchLineInformation(arm) \ + do { \ + envPtr->line = (arm)->bodyLine; /* TIP #280 */ \ + envPtr->clNext = (arm)->bodyContLines; /* TIP #280 */ \ + } while (0) + +/* + *---------------------------------------------------------------------- + * * TclCompileSwitchCmd -- * * Procedure called to compile the "switch" command. @@ -1787,20 +1760,17 @@ TclCompileSwitchCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; /* Pointer to tokens in command. */ - int numWords; /* Number of words in command. */ + Tcl_Size numWords; /* Number of words in command. */ Tcl_Token *valueTokenPtr; /* Token for the value to switch on. */ enum {Switch_Exact, Switch_Glob, Switch_Regexp} mode; /* What kind of switch are we doing? */ Tcl_Token *bodyTokenArray; /* Array of real pattern list items. */ - Tcl_Token **bodyToken; /* Array of pointers to pattern list items. */ - Tcl_Size *bodyLines; /* Array of line numbers for body list - * items. */ - Tcl_Size **bodyContLines; /* Array of continuation line info. */ + SwitchArmInfo *arms; /* Array of information about switch arms. */ int noCase; /* Has the -nocase flag been given? */ int foundMode = 0; /* Have we seen a mode flag yet? */ - int i, valueIndex; + Tcl_Size i, valueIndex; int result = TCL_ERROR; Tcl_Size *clNext = envPtr->clNext; @@ -1822,7 +1792,10 @@ TclCompileSwitchCmd( tokenPtr = TokenAfter(parsePtr->tokenPtr); valueIndex = 1; - numWords = parsePtr->numWords-1; + numWords = parsePtr->numWords - 1; + if (numWords > UINT_MAX) { + return TCL_ERROR; + } /* * Check for options. @@ -1849,9 +1822,6 @@ TclCompileSwitchCmd( */ for (; numWords>=3 ; tokenPtr=TokenAfter(tokenPtr),numWords--) { - size_t size = tokenPtr[1].size; - const char *chrs = tokenPtr[1].start; - /* * We only process literal options, and we assume that -e, -g and -n * are unique prefixes of -exact, -glob and -nocase respectively (true @@ -1859,11 +1829,7 @@ TclCompileSwitchCmd( * at most once or we bail out (error case). */ - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || size < 2) { - return TCL_ERROR; - } - - if ((size <= 6) && !memcmp(chrs, "-exact", size)) { + if (IS_TOKEN_PREFIX(tokenPtr, 2, "-exact")) { if (foundMode) { return TCL_ERROR; } @@ -1871,7 +1837,7 @@ TclCompileSwitchCmd( foundMode = 1; valueIndex++; continue; - } else if ((size <= 5) && !memcmp(chrs, "-glob", size)) { + } else if (IS_TOKEN_PREFIX(tokenPtr, 2, "-glob")) { if (foundMode) { return TCL_ERROR; } @@ -1879,7 +1845,7 @@ TclCompileSwitchCmd( foundMode = 1; valueIndex++; continue; - } else if ((size <= 7) && !memcmp(chrs, "-regexp", size)) { + } else if (IS_TOKEN_PREFIX(tokenPtr, 2, "-regexp")) { if (foundMode) { return TCL_ERROR; } @@ -1887,11 +1853,11 @@ TclCompileSwitchCmd( foundMode = 1; valueIndex++; continue; - } else if ((size <= 7) && !memcmp(chrs, "-nocase", size)) { + } else if (IS_TOKEN_PREFIX(tokenPtr, 2, "-nocase")) { noCase = 1; valueIndex++; continue; - } else if ((size == 2) && !memcmp(chrs, "--", 2)) { + } else if (IS_TOKEN_LITERALLY(tokenPtr, "--")) { valueIndex++; break; } @@ -1910,13 +1876,6 @@ TclCompileSwitchCmd( } tokenPtr = TokenAfter(tokenPtr); numWords--; - if (noCase && (mode == Switch_Exact)) { - /* - * Can't compile this case; no opcode for case-insensitive equality! - */ - - return TCL_ERROR; - } /* * The value to test against is going to always get pushed on the stack. @@ -1941,7 +1900,7 @@ TclCompileSwitchCmd( if (numWords == 1) { const char *bytes; Tcl_Size maxLen, numBytes; - Tcl_Size bline; /* TIP #280: line of the pattern/action list, + int bline; /* TIP #280: line of the pattern/action list, * and start of list for when tracking the * location. This list comes immediately after * the value we switch on. */ @@ -1957,52 +1916,67 @@ TclCompileSwitchCmd( if (maxLen < 2) { return TCL_ERROR; } - bodyTokenArray = (Tcl_Token *)Tcl_Alloc(sizeof(Tcl_Token) * maxLen); - bodyToken = (Tcl_Token **)Tcl_Alloc(sizeof(Tcl_Token *) * maxLen); - bodyLines = (Tcl_Size *)Tcl_Alloc(sizeof(Tcl_Size) * maxLen); - bodyContLines = (Tcl_Size **)Tcl_Alloc(sizeof(Tcl_Size*) * maxLen); + bodyTokenArray = (Tcl_Token *) TclStackAlloc(interp, + sizeof(Tcl_Token) * maxLen); + arms = (SwitchArmInfo *) TclStackAlloc(interp, + sizeof(SwitchArmInfo) * maxLen / 2); - bline = mapPtr->loc[eclIndex].line[valueIndex+1]; + bline = ExtCmdLocation.line[valueIndex + 1]; numWords = 0; + /* + * Need to be slightly careful; we're iterating over the words of the + * list, not the arms of the [switch]. This means we go round this loop + * twice per arm. + */ + while (numBytes > 0) { const char *prevBytes = bytes; - int literal; + int literal, isProcessingBody = (int)(numWords & 1); + SwitchArmInfo *arm = &arms[numWords >> 1]; + Tcl_Token *fakeToken = &bodyTokenArray[numWords]; if (TCL_OK != TclFindElement(NULL, bytes, numBytes, - &(bodyTokenArray[numWords].start), &bytes, - &(bodyTokenArray[numWords].size), &literal) || !literal) { - goto abort; + &fakeToken->start, &bytes, &fakeToken->size, &literal) + || !literal) { + goto freeTemporaries; } - bodyTokenArray[numWords].type = TCL_TOKEN_TEXT; - bodyTokenArray[numWords].numComponents = 0; - bodyToken[numWords] = bodyTokenArray + numWords; + fakeToken->type = TCL_TOKEN_TEXT; + fakeToken->numComponents = 0; + if (isProcessingBody) { + if (IsFallthroughToken(fakeToken)) { + arm->bodyToken = NULL; + } else { + arm->bodyToken = fakeToken; + } + } else { + arm->valueToken = fakeToken; + } /* * TIP #280: Now determine the line the list element starts on * (there is no need to do it earlier, due to the possibility of * aborting, see above). + * Don't need to record the information for the values; they're + * known to be compile-time literals. */ - TclAdvanceLines(&bline, prevBytes, bodyTokenArray[numWords].start); + TclAdvanceLines(&bline, prevBytes, fakeToken->start); TclAdvanceContinuations(&bline, &clNext, - bodyTokenArray[numWords].start - envPtr->source); - bodyLines[numWords] = bline; - bodyContLines[numWords] = clNext; - TclAdvanceLines(&bline, bodyTokenArray[numWords].start, bytes); + fakeToken->start - envPtr->source); + if (isProcessingBody) { + arm->bodyLine = bline; + arm->bodyContLines = clNext; + } + TclAdvanceLines(&bline, fakeToken->start, bytes); TclAdvanceContinuations(&bline, &clNext, bytes - envPtr->source); numBytes -= (bytes - prevBytes); numWords++; } if (numWords % 2) { - abort: - Tcl_Free(bodyToken); - Tcl_Free(bodyTokenArray); - Tcl_Free(bodyLines); - Tcl_Free(bodyContLines); - return TCL_ERROR; + goto freeTemporaries; } } else if (numWords % 2 || numWords == 0) { /* @@ -2019,10 +1993,9 @@ TclCompileSwitchCmd( * Multi-word definition of patterns & actions. */ - bodyToken = (Tcl_Token **)Tcl_Alloc(sizeof(Tcl_Token *) * numWords); - bodyLines = (Tcl_Size *)Tcl_Alloc(sizeof(Tcl_Size) * numWords); - bodyContLines = (Tcl_Size **)Tcl_Alloc(sizeof(Tcl_Size*) * numWords); bodyTokenArray = NULL; + arms = (SwitchArmInfo *) TclStackAlloc(interp, + sizeof(SwitchArmInfo) * numWords / 2); for (i=0 ; i<numWords ; i++) { /* * We only handle the very simplest case. Anything more complex is @@ -2030,17 +2003,24 @@ TclCompileSwitchCmd( * traces, etc. */ + int isProcessingBody = (int) (i & 1); + SwitchArmInfo *arm = &arms[i >> 1]; + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { goto freeTemporaries; } - bodyToken[i] = tokenPtr+1; - - /* - * TIP #280: Copy line information from regular cmd info. - */ - bodyLines[i] = mapPtr->loc[eclIndex].line[valueIndex+1+i]; - bodyContLines[i] = mapPtr->loc[eclIndex].next[valueIndex+1+i]; + if (isProcessingBody) { + if (IsFallthroughToken(tokenPtr)) { + arm->bodyToken = NULL; + } else { + arm->bodyToken = tokenPtr + 1; + } + arm->bodyLine = ExtCmdLocation.line[valueIndex + 1 + i]; + arm->bodyContLines = ExtCmdLocation.next[valueIndex + 1 + i]; + } else { + arm->valueToken = tokenPtr + 1; + } tokenPtr = TokenAfter(tokenPtr); } } @@ -2050,8 +2030,7 @@ TclCompileSwitchCmd( * illegal, but this makes the error happen at the right time). */ - if (bodyToken[numWords-1]->size == 1 && - bodyToken[numWords-1]->start[0] == '-') { + if (IsFallthroughArm(&arms[numWords / 2 - 1])) { goto freeTemporaries; } @@ -2064,14 +2043,12 @@ TclCompileSwitchCmd( */ /* Both methods push the value to match against onto the stack. */ - CompileWord(envPtr, valueTokenPtr, interp, valueIndex); + PUSH_TOKEN( valueTokenPtr, valueIndex); if (mode == Switch_Exact) { - IssueSwitchJumpTable(interp, envPtr, numWords, bodyToken, - bodyLines, bodyContLines); + IssueSwitchJumpTable(interp, envPtr, noCase, numWords/2, arms); } else { - IssueSwitchChainedTests(interp, envPtr, mode, noCase, - numWords, bodyToken, bodyLines, bodyContLines); + IssueSwitchChainedTests(interp, envPtr, mode, noCase, numWords/2, arms); } result = TCL_OK; @@ -2080,11 +2057,9 @@ TclCompileSwitchCmd( */ freeTemporaries: - Tcl_Free(bodyToken); - Tcl_Free(bodyLines); - Tcl_Free(bodyContLines); + TclStackFree(interp, arms); if (bodyTokenArray != NULL) { - Tcl_Free(bodyTokenArray); + TclStackFree(interp, bodyTokenArray); } return result; } @@ -2102,6 +2077,10 @@ TclCompileSwitchCmd( * wild-and-wooly end of regexp matching (i.e., capture of match results) * so that's when we spill to the interpreted version. * + * We assume (because it was checked by our caller) that there's at least + * one body, all tokens are literals, and all fallthroughs eventually hit + * something real. + * *---------------------------------------------------------------------- */ @@ -2111,58 +2090,53 @@ IssueSwitchChainedTests( CompileEnv *envPtr, /* Holds resulting instructions. */ int mode, /* Exact, Glob or Regexp */ int noCase, /* Case-insensitivity flag. */ - Tcl_Size numBodyTokens, /* Number of tokens describing things the - * switch can match against and bodies to - * execute when the match succeeds. */ - Tcl_Token **bodyToken, /* Array of pointers to pattern list items. */ - Tcl_Size *bodyLines, /* Array of line numbers for body list - * items. */ - Tcl_Size **bodyContLines) /* Array of continuation line info. */ + Tcl_Size numArms, /* Number of arms of the switch. */ + SwitchArmInfo *arms) /* Array of arm descriptors. */ { enum {Switch_Exact, Switch_Glob, Switch_Regexp}; int foundDefault; /* Flag to indicate whether a "default" clause * is present. */ - JumpFixup *fixupArray; /* Array of forward-jump fixup records. */ - unsigned int *fixupTargetArray; /* Array of places for fixups to point at. */ - int fixupCount; /* Number of places to fix up. */ - int contFixIndex; /* Where the first of the jumps due to a group + Tcl_BytecodeLabel *fwdJumps;/* Array of forward-jump fixup locations. */ + Tcl_Size jumpCount; /* Next cell to use in fwdJumps array. */ + Tcl_Size contJumpIdx; /* Where the first of the jumps due to a group * of continuation bodies starts, or -1 if * there aren't any. */ - int contFixCount; /* Number of continuation bodies pointing to + Tcl_Size contJumpCount; /* Number of continuation bodies pointing to * the current (or next) real body. */ - int nextArmFixupIndex; + Tcl_Size nextArmFixupIndex; /* Index of next issued arm to fix the jump to + * the next test for, or -1 if no fix pending. */ int simple, exact; /* For extracting the type of regexp. */ - int i; + Tcl_Size i, j; /* * Generate a test for each arm. */ - contFixIndex = -1; - contFixCount = 0; - fixupArray = (JumpFixup *)TclStackAlloc(interp, sizeof(JumpFixup) * numBodyTokens); - fixupTargetArray = (unsigned int *)TclStackAlloc(interp, sizeof(int) * numBodyTokens); - memset(fixupTargetArray, 0, numBodyTokens * sizeof(int)); - fixupCount = 0; + contJumpIdx = NO_PENDING_JUMP; + contJumpCount = 0; + fwdJumps = (Tcl_BytecodeLabel *)TclStackAlloc(interp, + sizeof(Tcl_BytecodeLabel) * numArms * 2); + jumpCount = 0; foundDefault = 0; - for (i=0 ; i<numBodyTokens ; i+=2) { - nextArmFixupIndex = -1; - if (i!=numBodyTokens-2 || bodyToken[numBodyTokens-2]->size != 7 || - memcmp(bodyToken[numBodyTokens-2]->start, "default", 7)) { + for (i=0 ; i<numArms ; i++) { + SwitchArmInfo *arm = &arms[i]; + + nextArmFixupIndex = NO_PENDING_JUMP; + if (i != numArms - 1 || !HasDefaultClause(numArms, arms)) { /* * Generate the test for the arm. */ switch (mode) { case Switch_Exact: - OP( DUP); - TclCompileTokens(interp, bodyToken[i], 1, envPtr); - OP( STR_EQ); + OP( DUP); + TclCompileTokens(interp, arm->valueToken, 1, envPtr); + OP( STR_EQ); break; case Switch_Glob: - TclCompileTokens(interp, bodyToken[i], 1, envPtr); - OP4( OVER, 1); - OP1( STR_MATCH, noCase); + TclCompileTokens(interp, arm->valueToken, 1, envPtr); + OP4( OVER, 1); + OP1( STR_MATCH, noCase); break; case Switch_Regexp: simple = exact = 0; @@ -2171,16 +2145,16 @@ IssueSwitchChainedTests( * Keep in sync with TclCompileRegexpCmd. */ - if (bodyToken[i]->type == TCL_TOKEN_TEXT) { + if (arms[i].valueToken->type == TCL_TOKEN_TEXT) { Tcl_DString ds; - if (bodyToken[i]->size == 0) { + if (arms[i].valueToken->size == 0) { /* * The semantics of regexps are that they always match * when the RE == "". */ - PUSH("1"); + PUSH( "1"); break; } @@ -2189,19 +2163,18 @@ IssueSwitchChainedTests( * the converted pattern. */ - if (TclReToGlob(NULL, bodyToken[i]->start, - bodyToken[i]->size, &ds, &exact, NULL) == TCL_OK){ + if (TclReToGlob(NULL, arm->valueToken->start, + arm->valueToken->size, &ds, &exact, NULL) == TCL_OK) { simple = 1; - PushLiteral(envPtr, Tcl_DStringValue(&ds), - Tcl_DStringLength(&ds)); + TclPushDString(envPtr, &ds); Tcl_DStringFree(&ds); } } if (!simple) { - TclCompileTokens(interp, bodyToken[i], 1, envPtr); + TclCompileTokens(interp, arm->valueToken, 1, envPtr); } - OP4( OVER, 1); + OP4( OVER, 1); if (!simple) { /* * Pass correct RE compile flags. We use only Int1 @@ -2210,14 +2183,13 @@ IssueSwitchChainedTests( * or capture vars. */ - int cflags = TCL_REG_ADVANCED - | (noCase ? TCL_REG_NOCASE : 0); + int cflags = TCL_REG_ADVANCED | (noCase ? TCL_REG_NOCASE : 0); - OP1(REGEXP, cflags); + OP1( REGEXP, cflags); } else if (exact && !noCase) { - OP( STR_EQ); + OP( STR_EQ); } else { - OP1(STR_MATCH, noCase); + OP1( STR_MATCH, noCase); } break; default: @@ -2230,22 +2202,19 @@ IssueSwitchChainedTests( * ensured earlier; the final body is never a fall-through). */ - if (bodyToken[i+1]->size==1 && bodyToken[i+1]->start[0]=='-') { - if (contFixIndex == -1) { - contFixIndex = fixupCount; - contFixCount = 0; + if (IsFallthroughArm(arm)) { + if (contJumpIdx == NO_PENDING_JUMP) { + contJumpIdx = jumpCount; + contJumpCount = 0; } - TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, - &fixupArray[contFixIndex+contFixCount]); - fixupCount++; - contFixCount++; + FWDJUMP( JUMP_TRUE, fwdJumps[contJumpIdx + contJumpCount]); + jumpCount++; + contJumpCount++; continue; } - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, - &fixupArray[fixupCount]); - nextArmFixupIndex = fixupCount; - fixupCount++; + FWDJUMP( JUMP_FALSE, fwdJumps[jumpCount]); + nextArmFixupIndex = jumpCount++; } else { /* * Got a default clause; set a flag to inhibit the generation of @@ -2267,13 +2236,12 @@ IssueSwitchChainedTests( * so we must process those first. */ - if (contFixIndex != -1) { - int j; - - for (j=0 ; j<contFixCount ; j++) { - fixupTargetArray[contFixIndex+j] = CurrentOffset(envPtr); + if (contJumpIdx != NO_PENDING_JUMP) { + for (j=0 ; j<contJumpCount ; j++) { + FWDLABEL( fwdJumps[contJumpIdx + j]); + fwdJumps[contJumpIdx + j] = 0; } - contFixIndex = -1; + contJumpIdx = NO_PENDING_JUMP; } /* @@ -2282,16 +2250,15 @@ IssueSwitchChainedTests( * pattern. */ - OP( POP); - envPtr->line = bodyLines[i+1]; /* TIP #280 */ - envPtr->clNext = bodyContLines[i+1]; /* TIP #280 */ - TclCompileCmdWord(interp, bodyToken[i+1], 1, envPtr); + OP( POP); + SetSwitchLineInformation(arm); + TclCompileCmdWord(interp, arm->bodyToken, 1, envPtr); if (!foundDefault) { - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, - &fixupArray[fixupCount]); - fixupCount++; - fixupTargetArray[nextArmFixupIndex] = CurrentOffset(envPtr); + FWDJUMP( JUMP, fwdJumps[jumpCount]); + jumpCount++; + FWDLABEL( fwdJumps[nextArmFixupIndex]); + fwdJumps[nextArmFixupIndex] = 0; } } @@ -2303,43 +2270,22 @@ IssueSwitchChainedTests( */ if (!foundDefault) { - OP( POP); - PUSH(""); + OP( POP); + PUSH( ""); } /* - * Do jump fixups for arms that were executed. First, fill in the jumps of - * all jumps that don't point elsewhere to point to here. + * Do jump fixups for arms that were executed and that haven't already + * been fixed. */ - for (i=0 ; i<fixupCount ; i++) { - if (fixupTargetArray[i] == 0) { - fixupTargetArray[i] = envPtr->codeNext-envPtr->codeStart; + for (j=0 ; j<jumpCount ; j++) { + if (fwdJumps[j] != 0) { + FWDLABEL( fwdJumps[j]); } } - /* - * Now scan backwards over all the jumps (all of which are forward jumps) - * doing each one. When we do one and there is a size changes, we must - * scan back over all the previous ones and see if they need adjusting - * before proceeding with further jump fixups (the interleaved nature of - * all the jumps makes this impossible to do without nested loops). - */ - - for (i=fixupCount-1 ; i>=0 ; i--) { - if (TclFixupForwardJump(envPtr, &fixupArray[i], - fixupTargetArray[i] - fixupArray[i].codeOffset, 127)) { - int j; - - for (j=i-1 ; j>=0 ; j--) { - if (fixupTargetArray[j] > fixupArray[i].codeOffset) { - fixupTargetArray[j] += 3; - } - } - } - } - TclStackFree(interp, fixupTargetArray); - TclStackFree(interp, fixupArray); + TclStackFree(interp, fwdJumps); } /* @@ -2352,6 +2298,10 @@ IssueSwitchChainedTests( * exact matching is used, but this is actually the most common case in * real code. * + * We assume (because it was checked by our caller) that there's at least + * one body, all tokens are literals, and all fallthroughs eventually hit + * something real. + * *---------------------------------------------------------------------- */ @@ -2359,19 +2309,24 @@ static void IssueSwitchJumpTable( Tcl_Interp *interp, /* Context for compiling script bodies. */ CompileEnv *envPtr, /* Holds resulting instructions. */ - int numBodyTokens, /* Number of tokens describing things the - * switch can match against and bodies to - * execute when the match succeeds. */ - Tcl_Token **bodyToken, /* Array of pointers to pattern list items. */ - Tcl_Size *bodyLines, /* Array of line numbers for body list - * items. */ - Tcl_Size **bodyContLines) /* Array of continuation line info. */ + int noCase, /* Whether to do case-insensitive matches. */ + Tcl_Size numArms, /* Number of arms of the switch. */ + SwitchArmInfo *arms) /* Array of arm descriptors. */ { JumptableInfo *jtPtr; - int infoIndex, isNew, *finalFixups, numRealBodies = 0, jumpLocation; - int mustGenerate, foundDefault, jumpToDefault, i; + Tcl_AuxDataRef infoIndex; + int isNew, mustGenerate, foundDefault; + Tcl_Size numRealBodies = 0, i; + Tcl_BytecodeLabel jumpLocation, jumpToDefault, *finalFixups; Tcl_DString buffer; - Tcl_HashEntry *hPtr; + + /* + * If doing case-insensitive matching, convert to lower case and then do + * exact string matching. + */ + if (noCase) { + OP( STR_LOWER); + } /* * Compile the switch by using a jump table, which is basically a @@ -2383,10 +2338,10 @@ IssueSwitchJumpTable( * Start by allocating the jump table itself, plus some workspace. */ - jtPtr = (JumptableInfo *)Tcl_Alloc(sizeof(JumptableInfo)); - Tcl_InitHashTable(&jtPtr->hashTable, TCL_STRING_KEYS); - infoIndex = TclCreateAuxData(jtPtr, &tclJumptableInfoType, envPtr); - finalFixups = (int *)TclStackAlloc(interp, sizeof(int) * (numBodyTokens/2)); + jtPtr = AllocJumptable(); + infoIndex = RegisterJumptable(jtPtr, envPtr); + finalFixups = (Tcl_BytecodeLabel *)TclStackAlloc(interp, + sizeof(Tcl_BytecodeLabel) * numArms); foundDefault = 0; mustGenerate = 1; @@ -2399,39 +2354,42 @@ IssueSwitchJumpTable( * because that makes the code much easier to debug! */ - jumpLocation = CurrentOffset(envPtr); - OP4( JUMP_TABLE, infoIndex); - jumpToDefault = CurrentOffset(envPtr); - OP4( JUMP4, 0); + BACKLABEL( jumpLocation); + OP4( JUMP_TABLE, infoIndex); + FWDJUMP( JUMP, jumpToDefault); + + for (i=0 ; i<numArms ; i++) { + SwitchArmInfo *arm = &arms[i]; - for (i=0 ; i<numBodyTokens ; i+=2) { /* * For each arm, we must first work out what to do with the match * term. */ - if (i!=numBodyTokens-2 || bodyToken[numBodyTokens-2]->size != 7 || - memcmp(bodyToken[numBodyTokens-2]->start, "default", 7)) { + if (i != numArms-1 || !HasDefaultClause(numArms, arms)) { /* * This is not a default clause, so insert the current location as * a target in the jump table (assuming it isn't already there, * which would indicate that this clause is probably masked by an * earlier one). Note that we use a Tcl_DString here simply * because the hash API does not let us specify the string length. + * + * If we're doing case-insensitive matching, we construct the table + * with all keys being lower case strings. */ Tcl_DStringInit(&buffer); - TclDStringAppendToken(&buffer, bodyToken[i]); - hPtr = Tcl_CreateHashEntry(&jtPtr->hashTable, - Tcl_DStringValue(&buffer), &isNew); - if (isNew) { + TclDStringAppendToken(&buffer, arm->valueToken); + if (noCase) { /* - * First time we've encountered this match clause, so it must - * point to here. + * We do case-insensitive matching by conversion to lower case. */ - Tcl_SetHashValue(hPtr, INT2PTR(CurrentOffset(envPtr) - jumpLocation)); + Tcl_Size slength = Tcl_UtfToLower(Tcl_DStringValue(&buffer)); + Tcl_DStringSetLength(&buffer, slength); } + isNew = CreateJumptableEntry(jtPtr, Tcl_DStringValue(&buffer), + CurrentOffset(envPtr) - jumpLocation); Tcl_DStringFree(&buffer); } else { /* @@ -2441,8 +2399,7 @@ IssueSwitchJumpTable( foundDefault = 1; isNew = 1; - TclStoreInt4AtPtr(CurrentOffset(envPtr)-jumpToDefault, - envPtr->codeStart+jumpToDefault+1); + FWDLABEL( jumpToDefault); } /* @@ -2453,7 +2410,7 @@ IssueSwitchJumpTable( * will also point here, so we advance to the next clause. */ - if (bodyToken[i+1]->size == 1 && bodyToken[i+1]->start[0] == '-') { + if (IsFallthroughArm(arm)) { mustGenerate = 1; continue; } @@ -2473,9 +2430,8 @@ IssueSwitchJumpTable( * Compile the body of the arm. */ - envPtr->line = bodyLines[i+1]; /* TIP #280 */ - envPtr->clNext = bodyContLines[i+1]; /* TIP #280 */ - TclCompileCmdWord(interp, bodyToken[i+1], 1, envPtr); + SetSwitchLineInformation(arm); + TclCompileCmdWord(interp, arm->bodyToken, 1, envPtr); /* * Compile a jump in to the end of the command if this body is @@ -2484,17 +2440,9 @@ IssueSwitchJumpTable( * result). */ - if (i+2 < numBodyTokens || !foundDefault) { - finalFixups[numRealBodies++] = CurrentOffset(envPtr); - - /* - * Easier by far to issue this jump as a fixed-width jump, since - * otherwise we'd need to do a lot more (and more awkward) - * rewriting when we fixed this all up. - */ - - OP4( JUMP4, 0); - TclAdjustStackDepth(-1, envPtr); + if (i < numArms-1 || !foundDefault) { + FWDJUMP( JUMP, finalFixups[numRealBodies++]); + STKDELTA(-1); } } @@ -2505,9 +2453,8 @@ IssueSwitchJumpTable( */ if (!foundDefault) { - TclStoreInt4AtPtr(CurrentOffset(envPtr)-jumpToDefault, - envPtr->codeStart+jumpToDefault+1); - PUSH(""); + FWDLABEL( jumpToDefault); + PUSH( ""); } /* @@ -2516,8 +2463,7 @@ IssueSwitchJumpTable( */ for (i=0 ; i<numRealBodies ; i++) { - TclStoreInt4AtPtr(CurrentOffset(envPtr)-finalFixups[i], - envPtr->codeStart+finalFixups[i]+1); + FWDLABEL( finalFixups[i]); } /* @@ -2530,22 +2476,28 @@ IssueSwitchJumpTable( /* *---------------------------------------------------------------------- * - * DupJumptableInfo, FreeJumptableInfo -- + * DupJumptableInfo, FreeJumptableInfo, etc -- * - * Functions to duplicate, release and print a jump-table created for use - * with the INST_JUMP_TABLE instruction. + * Functions to duplicate, release and print jump-tables created for use + * with the INST_JUMP_TABLE or INST_JUMP_TABLE_NUM instructions. * * Results: * DupJumptableInfo: a copy of the jump-table * FreeJumptableInfo: none * PrintJumptableInfo: none * DisassembleJumptableInfo: none + * DupJumptableNumInfo: a copy of the jump-table + * PrintJumptableNumInfo: none + * DisassembleJumptableNumInfo: none * * Side effects: * DupJumptableInfo: allocates memory * FreeJumptableInfo: releases memory * PrintJumptableInfo: none * DisassembleJumptableInfo: none + * DupJumptableNumInfo: allocates memory + * PrintJumptableNumInfo: none + * DisassembleJumptableNumInfo: none * *---------------------------------------------------------------------- */ @@ -2555,16 +2507,14 @@ DupJumptableInfo( void *clientData) { JumptableInfo *jtPtr = (JumptableInfo *)clientData; - JumptableInfo *newJtPtr = (JumptableInfo *)Tcl_Alloc(sizeof(JumptableInfo)); + JumptableInfo *newJtPtr = AllocJumptable(); Tcl_HashEntry *hPtr, *newHPtr; Tcl_HashSearch search; - int isNew; - Tcl_InitHashTable(&newJtPtr->hashTable, TCL_STRING_KEYS); hPtr = Tcl_FirstHashEntry(&jtPtr->hashTable, &search); for (; hPtr ; hPtr = Tcl_NextHashEntry(&search)) { newHPtr = Tcl_CreateHashEntry(&newJtPtr->hashTable, - Tcl_GetHashKey(&jtPtr->hashTable, hPtr), &isNew); + Tcl_GetHashKey(&jtPtr->hashTable, hPtr), NULL); Tcl_SetHashValue(newHPtr, Tcl_GetHashValue(hPtr)); } return newJtPtr; @@ -2599,9 +2549,9 @@ PrintJumptableInfo( offset = PTR2INT(Tcl_GetHashValue(hPtr)); if (i++) { - Tcl_AppendToObj(appendObj, ", ", -1); - if (i%4==0) { - Tcl_AppendToObj(appendObj, "\n\t\t", -1); + Tcl_AppendToObj(appendObj, ", ", TCL_AUTO_LENGTH); + if (i % 4 == 0) { + Tcl_AppendToObj(appendObj, "\n\t\t", TCL_AUTO_LENGTH); } } Tcl_AppendPrintfToObj(appendObj, "\"%s\"->pc %" TCL_Z_MODIFIER "u", @@ -2632,6 +2582,82 @@ DisassembleJumptableInfo( } TclDictPut(NULL, dictObj, "mapping", mapping); } + +static void * +DupJumptableNumInfo( + void *clientData) +{ + JumptableNumInfo *jtnPtr = (JumptableNumInfo *) clientData; + JumptableNumInfo *newJtnPtr = AllocJumptableNum(); + Tcl_HashEntry *hPtr, *newHPtr; + Tcl_HashSearch search; + + hPtr = Tcl_FirstHashEntry(&jtnPtr->hashTable, &search); + for (; hPtr ; hPtr = Tcl_NextHashEntry(&search)) { + newHPtr = Tcl_CreateHashEntry(&newJtnPtr->hashTable, + Tcl_GetHashKey(&jtnPtr->hashTable, hPtr), NULL); + Tcl_SetHashValue(newHPtr, Tcl_GetHashValue(hPtr)); + } + return newJtnPtr; +} + +// No FreeJumptableNumInfo; same as FreeJumptableInfo + +static void +PrintJumptableNumInfo( + void *clientData, + Tcl_Obj *appendObj, + TCL_UNUSED(ByteCode *), + size_t pcOffset) +{ + JumptableNumInfo *jtnPtr = (JumptableNumInfo *)clientData; + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + Tcl_Size key; + size_t offset, i = 0; + + hPtr = Tcl_FirstHashEntry(&jtnPtr->hashTable, &search); + for (; hPtr ; hPtr = Tcl_NextHashEntry(&search)) { + key = (Tcl_Size) Tcl_GetHashKey(&jtnPtr->hashTable, hPtr); + offset = PTR2INT(Tcl_GetHashValue(hPtr)); + + if (i++) { + Tcl_AppendToObj(appendObj, ", ", TCL_AUTO_LENGTH); + if (i%4==0) { + Tcl_AppendToObj(appendObj, "\n\t\t", TCL_AUTO_LENGTH); + } + } + Tcl_AppendPrintfToObj(appendObj, + "%" TCL_SIZE_MODIFIER "d->pc %" TCL_Z_MODIFIER "u", + key, pcOffset + offset); + } +} + +static void +DisassembleJumptableNumInfo( + void *clientData, + Tcl_Obj *dictObj, + TCL_UNUSED(ByteCode *), + TCL_UNUSED(size_t)) +{ + JumptableNumInfo *jtnPtr = (JumptableNumInfo *)clientData; + Tcl_Obj *mapping; + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + Tcl_Size key; + size_t offset; + + TclNewObj(mapping); + hPtr = Tcl_FirstHashEntry(&jtnPtr->hashTable, &search); + for (; hPtr ; hPtr = Tcl_NextHashEntry(&search)) { + key = (Tcl_Size) Tcl_GetHashKey(&jtnPtr->hashTable, hPtr); + offset = PTR2INT(Tcl_GetHashValue(hPtr)); + // Cannot fail: keys already known to be unique + Tcl_DictObjPut(NULL, mapping, Tcl_NewWideIntObj(key), + Tcl_NewWideIntObj(offset)); + } + TclDictPut(NULL, dictObj, "mapping", mapping); +} /* *---------------------------------------------------------------------- @@ -2661,21 +2687,97 @@ TclCompileTailcallCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr = parsePtr->tokenPtr; - int i; + Tcl_Size i, numWords = parsePtr->numWords; + Tcl_Size build = 1; + int concat = 0; - if (parsePtr->numWords < 2 || parsePtr->numWords >= 256 - || envPtr->procPtr == NULL) { + if (!EnvIsProc(envPtr)) { return TCL_ERROR; } - /* make room for the nsObjPtr */ - /* TODO: Doesn't this have to be a known value? */ - CompileWord(envPtr, tokenPtr, interp, 0); - for (i=1 ; i<(int)parsePtr->numWords ; i++) { + // All paths want the current namespace at this point. + OP( NS_CURRENT); + + // If the number of words is too large, use the concat sequence. + // Also send the no-command route there. + if (numWords < 2 || numWords > LIST_CONCAT_THRESHOLD) { + goto tailcallExpanded; + } + + // Check if we're doing expansion. + for (i=1 ; i<numWords ; i++) { tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, i); + if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { + goto tailcallExpanded; + } + } + tokenPtr = parsePtr->tokenPtr; + + // Push the words. The first one is marked for limited sharing. + for (i=1 ; i<numWords ; i++) { + tokenPtr = TokenAfter(tokenPtr); + if (i == 1 && tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + PUSH_COMMAND_TOKEN( tokenPtr); + } else { + PUSH_TOKEN( tokenPtr, i); + } + } + + // The tailcall operation itself. + OP4( TAILCALL, numWords); + return TCL_OK; + + tailcallExpanded: + // Build all the words into a list. Handles expansion. + tokenPtr = parsePtr->tokenPtr; + for (i = 1; i < numWords; i++) { + tokenPtr = TokenAfter(tokenPtr); + // If we're about to expand, make sure we have a single list before. + if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD && build > 0) { + OP4( LIST, build); + if (concat) { + OP( LIST_CONCAT); + } + build = 0; + concat = 1; + } + // Push the word. The first one is marked for limited sharing. + if (i == 1 && tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + PUSH_COMMAND_TOKEN( tokenPtr); + } else { + PUSH_TOKEN( tokenPtr, i); + } + // If it was expansion, join to list. + if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { + if (concat) { + OP( LIST_CONCAT); + } else { + concat = 1; + } + } else { + // Otherwise, count how many words are pending to make into a list. + build++; + } + // Too many words pending? Convert to a list now. + if (build > LIST_CONCAT_THRESHOLD) { + OP4( LIST, build); + if (concat) { + OP( LIST_CONCAT); + } + build = 0; + concat = 1; + } + } + // Anything left over? Handle now. + if (build > 0) { + OP4( LIST, build); + if (concat) { + OP( LIST_CONCAT); + } } - TclEmitInstInt1( INST_TAILCALL, (int)parsePtr->numWords, envPtr); + + // The tailcall operation itself. + OP( TAILCALL_LIST); return TCL_OK; } @@ -2706,7 +2808,7 @@ TclCompileThrowCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ - int numWords = parsePtr->numWords; + Tcl_Size numWords = parsePtr->numWords; Tcl_Token *codeToken, *msgToken; Tcl_Obj *objPtr; int codeKnown, codeIsList, codeIsValid; @@ -2728,10 +2830,10 @@ TclCompileThrowCmd( * must come first in case substitution raises errors. */ if (!codeKnown) { - CompileWord(envPtr, codeToken, interp, 1); + PUSH_TOKEN( codeToken, 1); PUSH( "-errorcode"); } - CompileWord(envPtr, msgToken, interp, 2); + PUSH_TOKEN( msgToken, 2); codeIsList = codeKnown && (TCL_OK == TclListObjLength(interp, objPtr, &len)); @@ -2742,7 +2844,7 @@ TclCompileThrowCmd( TclNewObj(dictPtr); TclDictPut(NULL, dictPtr, "-errorcode", objPtr); - TclEmitPush(TclAddLiteralObj(envPtr, dictPtr, NULL), envPtr); + PUSH_OBJ( dictPtr); } TclDecrRefCount(objPtr); @@ -2760,6 +2862,7 @@ TclCompileThrowCmd( } if (!codeKnown) { + Tcl_BytecodeLabel popForError; /* * Argument validity checking has to be done by bytecode at * run time. @@ -2767,10 +2870,12 @@ TclCompileThrowCmd( OP4( REVERSE, 3); OP( DUP); OP( LIST_LENGTH); - OP1( JUMP_FALSE1, 16); + FWDJUMP( JUMP_FALSE, popForError); OP4( LIST, 2); OP44( RETURN_IMM, TCL_ERROR, 0); - TclAdjustStackDepth(2, envPtr); + + STKDELTA(+2); + FWDLABEL( popForError); OP( POP); OP( POP); OP( POP); @@ -2808,29 +2913,17 @@ TclCompileTryCmd( TCL_UNUSED(Command *), CompileEnv *envPtr) /* Holds resulting instructions. */ { - int numWords = parsePtr->numWords, numHandlers, result = TCL_ERROR; + Tcl_Size numHandlers, numWords = parsePtr->numWords; + int result = TCL_ERROR, anyTrapClauses = 0; Tcl_Token *bodyToken, *finallyToken, *tokenPtr; - Tcl_Token **handlerTokens = NULL; - Tcl_Obj **matchClauses = NULL; - int *matchCodes=NULL, *resultVarIndices=NULL, *optionVarIndices=NULL; - int i; + TryHandlerInfo staticHandler, *handlers = &staticHandler; + Tcl_Size handlerIdx = 0; - if (numWords < 2) { + if (numWords < 2 || numWords > UINT_MAX) { return TCL_ERROR; } bodyToken = TokenAfter(parsePtr->tokenPtr); - - if (numWords == 2) { - /* - * No handlers or finally; do nothing beyond evaluating the body. - */ - - DefineLineInformation; /* TIP #280 */ - BODY(bodyToken, 1); - return TCL_OK; - } - numWords -= 2; tokenPtr = TokenAfter(bodyToken); @@ -2841,40 +2934,41 @@ TclCompileTryCmd( numHandlers = numWords >> 2; numWords -= numHandlers * 4; if (numHandlers > 0) { - handlerTokens = (Tcl_Token**)TclStackAlloc(interp, sizeof(Tcl_Token*)*numHandlers); - matchClauses = (Tcl_Obj **)TclStackAlloc(interp, sizeof(Tcl_Obj *) * numHandlers); - memset(matchClauses, 0, sizeof(Tcl_Obj *) * numHandlers); - matchCodes = (int *)TclStackAlloc(interp, sizeof(int) * numHandlers); - resultVarIndices = (int *)TclStackAlloc(interp, sizeof(int) * numHandlers); - optionVarIndices = (int *)TclStackAlloc(interp, sizeof(int) * numHandlers); - - for (i=0 ; i<numHandlers ; i++) { + if (numHandlers > 1) { + handlers = (TryHandlerInfo *)TclStackAlloc(interp, + sizeof(TryHandlerInfo) * numHandlers); + } else { + handlers = &staticHandler; + } + + /* Bug [c587295271]. Initialize so they can be released on exit. */ + for (handlerIdx = 0; handlerIdx < numHandlers ; handlerIdx++) { + handlers[handlerIdx].matchClause = NULL; + } + + for (handlerIdx = 0; handlerIdx < numHandlers ; handlerIdx++) { Tcl_Obj *tmpObj, **objv; Tcl_Size objc; - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - goto failedToCompile; - } - if (tokenPtr[1].size == 4 - && !strncmp(tokenPtr[1].start, "trap", 4)) { + if (IS_TOKEN_LITERALLY(tokenPtr, "trap")) { /* * Parse the list of errorCode words to match against. */ - matchCodes[i] = TCL_ERROR; + handlers[handlerIdx].matchCode = TCL_ERROR; tokenPtr = TokenAfter(tokenPtr); TclNewObj(tmpObj); - Tcl_IncrRefCount(tmpObj); if (!TclWordKnownAtCompileTime(tokenPtr, tmpObj) || TclListObjLength(NULL, tmpObj, &objc) != TCL_OK || (objc == 0)) { - TclDecrRefCount(tmpObj); + Tcl_BounceRefCount(tmpObj); goto failedToCompile; } Tcl_ListObjReplace(NULL, tmpObj, 0, 0, 0, NULL); - matchClauses[i] = tmpObj; - } else if (tokenPtr[1].size == 2 - && !strncmp(tokenPtr[1].start, "on", 2)) { + Tcl_IncrRefCount(tmpObj); + handlers[handlerIdx].matchClause = tmpObj; + anyTrapClauses = 1; + } else if (IS_TOKEN_LITERALLY(tokenPtr, "on")) { int code; /* @@ -2883,17 +2977,17 @@ TclCompileTryCmd( tokenPtr = TokenAfter(tokenPtr); TclNewObj(tmpObj); - Tcl_IncrRefCount(tmpObj); if (!TclWordKnownAtCompileTime(tokenPtr, tmpObj)) { - TclDecrRefCount(tmpObj); + Tcl_BounceRefCount(tmpObj); goto failedToCompile; } if (TCL_ERROR == TclGetCompletionCodeFromObj(NULL, tmpObj, &code)) { - TclDecrRefCount(tmpObj); + Tcl_BounceRefCount(tmpObj); goto failedToCompile; } - matchCodes[i] = code; - TclDecrRefCount(tmpObj); + handlers[handlerIdx].matchCode = code; + handlers[handlerIdx].matchClause = NULL; + Tcl_BounceRefCount(tmpObj); } else { goto failedToCompile; } @@ -2904,41 +2998,40 @@ TclCompileTryCmd( tokenPtr = TokenAfter(tokenPtr); TclNewObj(tmpObj); - Tcl_IncrRefCount(tmpObj); if (!TclWordKnownAtCompileTime(tokenPtr, tmpObj)) { - TclDecrRefCount(tmpObj); + Tcl_BounceRefCount(tmpObj); goto failedToCompile; } if (TclListObjGetElements(NULL, tmpObj, &objc, &objv) != TCL_OK || (objc > 2)) { - TclDecrRefCount(tmpObj); + Tcl_BounceRefCount(tmpObj); goto failedToCompile; } if (objc > 0) { Tcl_Size len; const char *varname = TclGetStringFromObj(objv[0], &len); - resultVarIndices[i] = LocalScalar(varname, len, envPtr); - if (resultVarIndices[i] < 0) { - TclDecrRefCount(tmpObj); + handlers[handlerIdx].resultVar = LocalScalar(varname, len, envPtr); + if (handlers[handlerIdx].resultVar < 0) { + Tcl_BounceRefCount(tmpObj); goto failedToCompile; } } else { - resultVarIndices[i] = -1; + handlers[handlerIdx].resultVar = TCL_INDEX_NONE; } if (objc == 2) { Tcl_Size len; const char *varname = TclGetStringFromObj(objv[1], &len); - optionVarIndices[i] = LocalScalar(varname, len, envPtr); - if (optionVarIndices[i] < 0) { - TclDecrRefCount(tmpObj); + handlers[handlerIdx].optionVar = LocalScalar(varname, len, envPtr); + if (handlers[handlerIdx].optionVar < 0) { + Tcl_BounceRefCount(tmpObj); goto failedToCompile; } } else { - optionVarIndices[i] = -1; + handlers[handlerIdx].optionVar = TCL_INDEX_NONE; } - TclDecrRefCount(tmpObj); + Tcl_BounceRefCount(tmpObj); /* * Extract the body for this handler. @@ -2948,16 +3041,16 @@ TclCompileTryCmd( if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { goto failedToCompile; } - if (tokenPtr[1].size == 1 && tokenPtr[1].start[0] == '-') { - handlerTokens[i] = NULL; + if (IS_TOKEN_LITERALLY(tokenPtr, "-")) { + handlers[handlerIdx].tokenPtr = NULL; } else { - handlerTokens[i] = tokenPtr; + handlers[handlerIdx].tokenPtr = tokenPtr; } tokenPtr = TokenAfter(tokenPtr); } - if (handlerTokens[numHandlers-1] == NULL) { + if (handlers[numHandlers - 1].tokenPtr == NULL) { goto failedToCompile; } } @@ -2969,14 +3062,17 @@ TclCompileTryCmd( if (numWords == 0) { finallyToken = NULL; } else if (numWords == 2) { - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size != 7 - || strncmp(tokenPtr[1].start, "finally", 7)) { + if (!IS_TOKEN_LITERALLY(tokenPtr, "finally")) { goto failedToCompile; } finallyToken = TokenAfter(tokenPtr); if (finallyToken->type != TCL_TOKEN_SIMPLE_WORD) { goto failedToCompile; } + // Special case: empty finally clause + if (TclIsEmptyToken(finallyToken)) { + finallyToken = NULL; + } } else { goto failedToCompile; } @@ -2985,35 +3081,47 @@ TclCompileTryCmd( * Issue the bytecode. */ - if (!finallyToken) { - result = IssueTryClausesInstructions(interp, envPtr, bodyToken, - numHandlers, matchCodes, matchClauses, resultVarIndices, - optionVarIndices, handlerTokens); + if (!finallyToken && numHandlers == 0) { + /* + * No handlers or finally; do nothing beyond evaluating the body. + */ + + DefineLineInformation; /* TIP #280 */ + BODY( bodyToken, 1); + result = TCL_OK; + } else if (!finallyToken) { + if (!anyTrapClauses) { + result = IssueTryTraplessClausesInstructions(interp, envPtr, + bodyToken, numHandlers, handlers); + } else { + result = IssueTryClausesInstructions(interp, envPtr, bodyToken, + numHandlers, handlers); + } } else if (numHandlers == 0) { result = IssueTryFinallyInstructions(interp, envPtr, bodyToken, finallyToken); } else { - result = IssueTryClausesFinallyInstructions(interp, envPtr, bodyToken, - numHandlers, matchCodes, matchClauses, resultVarIndices, - optionVarIndices, handlerTokens, finallyToken); + if (!anyTrapClauses) { + result = IssueTryTraplessClausesFinallyInstructions(interp, envPtr, + bodyToken, numHandlers, handlers, finallyToken); + } else { + result = IssueTryClausesFinallyInstructions(interp, envPtr, + bodyToken, numHandlers, handlers, finallyToken); + } } /* * Delete any temporary state and finish off. */ - failedToCompile: - if (numHandlers > 0) { - for (i=0 ; i<numHandlers ; i++) { - if (matchClauses[i]) { - TclDecrRefCount(matchClauses[i]); - } +failedToCompile: + for (handlerIdx = 0; handlerIdx < numHandlers; ++handlerIdx) { + if (handlers[handlerIdx].matchClause) { + TclDecrRefCount(handlers[handlerIdx].matchClause); } - TclStackFree(interp, optionVarIndices); - TclStackFree(interp, resultVarIndices); - TclStackFree(interp, matchCodes); - TclStackFree(interp, matchClauses); - TclStackFree(interp, handlerTokens); + } + if (handlers != &staticHandler) { + TclStackFree(interp, handlers); } return result; } @@ -3021,16 +3129,15 @@ TclCompileTryCmd( /* *---------------------------------------------------------------------- * - * IssueTryClausesInstructions, IssueTryClausesFinallyInstructions, - * IssueTryFinallyInstructions -- + * IssueTryClausesInstructions, IssueTryTraplessClausesInstructions, + * IssueTryClausesFinallyInstructions, IssueTryFinallyInstructions, + * IssueTryTraplessClausesFinallyInstructions -- * * The code generators for [try]. Split from the parsing engine for * reasons of developer sanity, and also split between no-finally, * just-finally and with-finally cases because so many of the details of * generation vary between the three. * - * The macros below make the instruction issuing easier to follow. - * *---------------------------------------------------------------------- */ @@ -3039,20 +3146,17 @@ IssueTryClausesInstructions( Tcl_Interp *interp, CompileEnv *envPtr, Tcl_Token *bodyToken, - int numHandlers, - int *matchCodes, - Tcl_Obj **matchClauses, - int *resultVars, - int *optionVars, - Tcl_Token **handlerTokens) + Tcl_Size numHandlers, /* Min 1 */ + TryHandlerInfo *handlers) { DefineLineInformation; /* TIP #280 */ - int range, resultVar, optionsVar; - int i, j, forwardsNeedFixing = 0, trapZero = 0, afterBody = 0; - Tcl_Size slen, len; - int *addrsToFix, *forwardsToFix, notCodeJumpSource, notECJumpSource; - int *noError; - char buf[TCL_INTEGER_SPACE]; + Tcl_LVTIndex resultVar, optionsVar; + Tcl_Size i, j, len; + int continuationsPending = 0, trapZero = 0; + Tcl_ExceptionRange range; + Tcl_BytecodeLabel afterBody = 0, pushReturnOptions = 0; + Tcl_BytecodeLabel notCodeJumpSource, notECJumpSource, dontSpliceDuring; + Tcl_BytecodeLabel *continuationJumps, *afterReturn0, *noError; resultVar = AnonymousLocal(envPtr); optionsVar = AnonymousLocal(envPtr); @@ -3066,7 +3170,7 @@ IssueTryClausesInstructions( */ for (i=0 ; i<numHandlers ; i++) { - if (matchCodes[i] == 0) { + if (handlers[i].matchCode == 0) { trapZero = 1; break; } @@ -3079,30 +3183,33 @@ IssueTryClausesInstructions( * (and it's never called when there's a finally clause). */ - range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); - OP4( BEGIN_CATCH4, range); - ExceptionRangeStarts(envPtr, range); - BODY( bodyToken, 1); - ExceptionRangeEnds(envPtr, range); + range = MAKE_CATCH_RANGE(); + OP4( BEGIN_CATCH, range); + CATCH_RANGE(range) { + BODY( bodyToken, 1); + } if (!trapZero) { - OP( END_CATCH); - JUMP4( JUMP, afterBody); - TclAdjustStackDepth(-1, envPtr); + OP( END_CATCH); + FWDJUMP( JUMP, afterBody); + STKDELTA(-1); } else { - PUSH( "0"); - OP4( REVERSE, 2); - OP1( JUMP1, 4); - TclAdjustStackDepth(-2, envPtr); - } - ExceptionRangeTarget(envPtr, range, catchOffset); - OP( PUSH_RETURN_CODE); - OP( PUSH_RESULT); - OP( PUSH_RETURN_OPTIONS); - OP( END_CATCH); - STORE( optionsVar); - OP( POP); - STORE( resultVar); - OP( POP); + PUSH( "0"); + OP( SWAP); + FWDJUMP( JUMP, pushReturnOptions); + STKDELTA(-2); + } + CATCH_TARGET( range); + OP( PUSH_RETURN_CODE); + OP( PUSH_RESULT); + if (pushReturnOptions > 0) { + FWDLABEL( pushReturnOptions); + } + OP( PUSH_RETURN_OPTIONS); + OP( END_CATCH); + OP4( STORE_SCALAR, optionsVar); + OP( POP); + OP4( STORE_SCALAR, resultVar); + OP( POP); /* * Now we handle all the registered 'on' and 'trap' handlers in order. @@ -3111,38 +3218,36 @@ IssueTryClausesInstructions( * Slight overallocation, but reduces size of this function. */ - addrsToFix = (int *)TclStackAlloc(interp, sizeof(int)*numHandlers); - forwardsToFix = (int *)TclStackAlloc(interp, sizeof(int)*numHandlers); - noError = (int *)TclStackAlloc(interp, sizeof(int)*numHandlers); + afterReturn0 = (Tcl_BytecodeLabel *)TclStackAlloc(interp, + sizeof(Tcl_BytecodeLabel) * numHandlers * 3); + continuationJumps = afterReturn0 + numHandlers; + noError = continuationJumps + numHandlers; + for (i=0; i<numHandlers*3; i++) { + afterReturn0[i] = NO_PENDING_JUMP; + } for (i=0 ; i<numHandlers ; i++) { - noError[i] = -1; - snprintf(buf, sizeof(buf), "%d", matchCodes[i]); - OP( DUP); - PushLiteral(envPtr, buf, strlen(buf)); - OP( EQ); - JUMP4( JUMP_FALSE, notCodeJumpSource); - if (matchClauses[i]) { - const char *p; - TclListObjLength(NULL, matchClauses[i], &len); + OP( DUP); + PUSH_OBJ( Tcl_NewIntObj(handlers[i].matchCode)); + OP( EQ); + FWDJUMP( JUMP_FALSE, notCodeJumpSource); + if (handlers[i].matchClause) { + TclListObjLength(NULL, handlers[i].matchClause, &len); /* * Match the errorcode according to try/trap rules. */ - LOAD( optionsVar); - PUSH( "-errorcode"); - OP4( DICT_GET, 1); - TclAdjustStackDepth(-1, envPtr); - OP44( LIST_RANGE_IMM, 0, len-1); - p = TclGetStringFromObj(matchClauses[i], &slen); - PushLiteral(envPtr, p, slen); - OP( STR_EQ); - JUMP4( JUMP_FALSE, notECJumpSource); + OP4( LOAD_SCALAR, optionsVar); + PUSH( "-errorcode"); + OP4( DICT_GET, 1); + PUSH_OBJ( handlers[i].matchClause); + OP4( ERROR_PREFIX_EQ, len); + FWDJUMP( JUMP_FALSE, notECJumpSource); } else { - notECJumpSource = -1; + notECJumpSource = NO_PENDING_JUMP; } - OP( POP); + OP( POP); /* * There is no finally clause, so we can avoid wrapping a catch @@ -3150,68 +3255,70 @@ IssueTryClausesInstructions( * to be issued a lot since we can let errors just fall through. */ - if (resultVars[i] >= 0) { - LOAD( resultVar); - STORE( resultVars[i]); - OP( POP); - if (optionVars[i] >= 0) { - LOAD( optionsVar); - STORE( optionVars[i]); - OP( POP); - } + if (handlers[i].resultVar != TCL_INDEX_NONE) { + OP4( LOAD_SCALAR, resultVar); + OP4( STORE_SCALAR, handlers[i].resultVar); + OP( POP); } - if (!handlerTokens[i]) { - forwardsNeedFixing = 1; - JUMP4( JUMP, forwardsToFix[i]); - TclAdjustStackDepth(1, envPtr); + if (handlers[i].optionVar != TCL_INDEX_NONE) { + OP4( LOAD_SCALAR, optionsVar); + OP4( STORE_SCALAR, handlers[i].optionVar); + OP( POP); + } + if (!handlers[i].tokenPtr) { + continuationsPending = 1; + FWDJUMP( JUMP, continuationJumps[i]); + STKDELTA(+1); } else { - int dontChangeOptions; - - forwardsToFix[i] = -1; - if (forwardsNeedFixing) { - forwardsNeedFixing = 0; + if (continuationsPending) { + continuationsPending = 0; for (j=0 ; j<i ; j++) { - if (forwardsToFix[j] == -1) { - continue; + if (continuationJumps[j] != NO_PENDING_JUMP) { + FWDLABEL(continuationJumps[j]); } - FIXJUMP4(forwardsToFix[j]); - forwardsToFix[j] = -1; + continuationJumps[j] = NO_PENDING_JUMP; } } - range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); - OP4( BEGIN_CATCH4, range); - ExceptionRangeStarts(envPtr, range); - BODY( handlerTokens[i], 5+i*4); - ExceptionRangeEnds(envPtr, range); - OP( END_CATCH); - JUMP4( JUMP, noError[i]); - ExceptionRangeTarget(envPtr, range, catchOffset); - TclAdjustStackDepth(-1, envPtr); - OP( PUSH_RESULT); - OP( PUSH_RETURN_OPTIONS); - OP( PUSH_RETURN_CODE); - OP( END_CATCH); - PUSH( "1"); - OP( EQ); - JUMP1( JUMP_FALSE, dontChangeOptions); - LOAD( optionsVar); - OP4( REVERSE, 2); - STORE( optionsVar); - OP( POP); - PUSH( "-during"); - OP4( REVERSE, 2); - OP44( DICT_SET, 1, optionsVar); - TclAdjustStackDepth(-1, envPtr); - FIXJUMP1( dontChangeOptions); - OP4( REVERSE, 2); - INVOKE( RETURN_STK); + + if (TclIsEmptyToken(handlers[i].tokenPtr)) { + // Empty handler body; can't generate non-trivial result tuple + PUSH( ""); + FWDJUMP( JUMP, noError[i]); + } else { + range = MAKE_CATCH_RANGE(); + OP4( BEGIN_CATCH, range); + CATCH_RANGE(range) { + BODY( handlers[i].tokenPtr, 5 + i*4); + } + OP( END_CATCH); + FWDJUMP( JUMP, noError[i]); + + STKDELTA(-1); + CATCH_TARGET(range); + OP( PUSH_RESULT); + OP( PUSH_RETURN_OPTIONS); + OP( PUSH_RETURN_CODE); + OP( END_CATCH); + + PUSH( "1"); + OP( EQ); + FWDJUMP( JUMP_FALSE, dontSpliceDuring); + // Next bit isn't DICT_SET; alter which dict is in optionsVar + PUSH( "-during"); + OP4( LOAD_SCALAR, optionsVar); + OP( DICT_PUT); + FWDLABEL( dontSpliceDuring); + + OP( SWAP); + INVOKE( RETURN_STK); + FWDJUMP( JUMP, afterReturn0[i]); + } } - JUMP4( JUMP, addrsToFix[i]); - if (matchClauses[i]) { - FIXJUMP4( notECJumpSource); + if (handlers[i].matchClause) { + FWDLABEL( notECJumpSource); } - FIXJUMP4( notCodeJumpSource); + FWDLABEL( notCodeJumpSource); } /* @@ -3220,10 +3327,10 @@ IssueTryClausesInstructions( * instruction. */ - OP( POP); - LOAD( optionsVar); - LOAD( resultVar); - INVOKE( RETURN_STK); + OP( POP); + OP4( LOAD_SCALAR, optionsVar); + OP4( LOAD_SCALAR, resultVar); + INVOKE( RETURN_STK); /* * Fix all the jumps from taken clauses to here (which is the end of the @@ -3231,45 +3338,235 @@ IssueTryClausesInstructions( */ if (!trapZero) { - FIXJUMP4(afterBody); + FWDLABEL( afterBody); } for (i=0 ; i<numHandlers ; i++) { - FIXJUMP4(addrsToFix[i]); - if (noError[i] != -1) { - FIXJUMP4(noError[i]); + if (afterReturn0[i] != NO_PENDING_JUMP) { + FWDLABEL( afterReturn0[i]); + } + if (noError[i] != NO_PENDING_JUMP) { + FWDLABEL( noError[i]); } } - TclStackFree(interp, noError); - TclStackFree(interp, forwardsToFix); - TclStackFree(interp, addrsToFix); + TclStackFree(interp, afterReturn0); return TCL_OK; } static int -IssueTryClausesFinallyInstructions( +IssueTryTraplessClausesInstructions( Tcl_Interp *interp, CompileEnv *envPtr, Tcl_Token *bodyToken, - int numHandlers, - int *matchCodes, - Tcl_Obj **matchClauses, - int *resultVars, - int *optionVars, - Tcl_Token **handlerTokens, - Tcl_Token *finallyToken) /* Not NULL */ + Tcl_Size numHandlers, /* Min 1 */ + TryHandlerInfo *handlers) { DefineLineInformation; /* TIP #280 */ - int range, resultVar, optionsVar, i, j, forwardsNeedFixing = 0; - int trapZero = 0, afterBody = 0, finalOK, finalError, noFinalError; - int *addrsToFix, *forwardsToFix, notCodeJumpSource, notECJumpSource; - char buf[TCL_INTEGER_SPACE]; - Tcl_Size slen, len; + Tcl_LVTIndex resultVar, optionsVar; + Tcl_Size i, j; + int continuationsPending = 0, trapZero = 0; + Tcl_ExceptionRange range; + Tcl_BytecodeLabel afterBody = 0, pushReturnOptions = 0; + Tcl_BytecodeLabel dontSpliceDuring, tableBase, haveOther; + Tcl_BytecodeLabel *continuationJumps, *afterReturn0, *noError; + JumptableNumInfo *tablePtr; + Tcl_AuxDataRef tableIdx; resultVar = AnonymousLocal(envPtr); optionsVar = AnonymousLocal(envPtr); if (resultVar < 0 || optionsVar < 0) { return TCL_ERROR; } + afterReturn0 = (Tcl_BytecodeLabel *)TclStackAlloc(interp, + sizeof(Tcl_BytecodeLabel) * numHandlers * 3); + continuationJumps = afterReturn0 + numHandlers; + noError = continuationJumps + numHandlers; + for (i=0; i<numHandlers*3; i++) { + afterReturn0[i] = NO_PENDING_JUMP; + } + tablePtr = AllocJumptableNum(); + tableIdx = RegisterJumptableNum(tablePtr, envPtr); + + /* + * Check if we're supposed to trap a normal TCL_OK completion of the body. + * If not, we can handle that case much more efficiently. + */ + + for (i=0 ; i<numHandlers ; i++) { + if (handlers[i].matchCode == 0) { + trapZero = 1; + break; + } + } + + /* + * Compile the body, trapping any error in it so that we can trap on it + * and/or run a finally clause. Note that there must be at least one + * on/trap clause; when none is present, this whole function is not called + * (and it's never called when there's a finally clause). + */ + + range = MAKE_CATCH_RANGE(); + OP4( BEGIN_CATCH, range); + CATCH_RANGE(range) { + BODY( bodyToken, 1); + } + if (!trapZero) { + OP( END_CATCH); + FWDJUMP( JUMP, afterBody); + STKDELTA(-1); + } else { + PUSH( "0"); + OP( SWAP); + FWDJUMP( JUMP, pushReturnOptions); + STKDELTA(-2); + } + CATCH_TARGET( range); + OP( PUSH_RETURN_CODE); + OP( PUSH_RESULT); + if (pushReturnOptions > 0) { + FWDLABEL( pushReturnOptions); + } + OP( PUSH_RETURN_OPTIONS); + OP( END_CATCH); + OP4( STORE_SCALAR, optionsVar); + OP( POP); + OP4( STORE_SCALAR, resultVar); + OP( POP); + + /* + * Now we handle all the registered 'on' handlers. + * For us to be here, there must be at least one handler. + * + * Slight overallocation, but reduces size of this function. + */ + + BACKLABEL( tableBase); + OP4( JUMP_TABLE_NUM, tableIdx); + FWDJUMP( JUMP, haveOther); + for (i=0 ; i<numHandlers ; i++) { + CreateJumptableNumEntryToHere(tablePtr, handlers[i].matchCode, tableBase); + + /* + * There is no finally clause, so we can avoid wrapping a catch + * context around the handler. That simplifies what instructions need + * to be issued a lot since we can let errors just fall through. + */ + + if (handlers[i].resultVar != TCL_INDEX_NONE) { + OP4( LOAD_SCALAR, resultVar); + OP4( STORE_SCALAR, handlers[i].resultVar); + OP( POP); + } + if (handlers[i].optionVar != TCL_INDEX_NONE) { + OP4( LOAD_SCALAR, optionsVar); + OP4( STORE_SCALAR, handlers[i].optionVar); + OP( POP); + } + if (!handlers[i].tokenPtr) { + continuationsPending = 1; + FWDJUMP( JUMP, continuationJumps[i]); + } else { + if (continuationsPending) { + continuationsPending = 0; + for (j=0 ; j<i ; j++) { + if (continuationJumps[j] != NO_PENDING_JUMP) { + FWDLABEL(continuationJumps[j]); + } + continuationJumps[j] = NO_PENDING_JUMP; + } + } + + if (TclIsEmptyToken(handlers[i].tokenPtr)) { + // Empty handler body; can't generate non-trivial result tuple + PUSH( ""); + FWDJUMP( JUMP, noError[i]); + } else { + range = MAKE_CATCH_RANGE(); + OP4( BEGIN_CATCH, range); + CATCH_RANGE(range) { + BODY( handlers[i].tokenPtr, 5 + i*4); + } + OP( END_CATCH); + FWDJUMP( JUMP, noError[i]); + + STKDELTA(-1); + CATCH_TARGET(range); + OP( PUSH_RESULT); + OP( PUSH_RETURN_OPTIONS); + OP( PUSH_RETURN_CODE); + OP( END_CATCH); + + PUSH( "1"); + OP( EQ); + FWDJUMP( JUMP_FALSE, dontSpliceDuring); + // Next bit isn't DICT_SET; alter which dict is in optionsVar + PUSH( "-during"); + OP4( LOAD_SCALAR, optionsVar); + OP( DICT_PUT); + FWDLABEL( dontSpliceDuring); + + OP( SWAP); + INVOKE( RETURN_STK); + FWDJUMP( JUMP, afterReturn0[i]); + } + STKDELTA(-1); + } + } + + /* + * Drop the result code since it didn't match any clause, and reissue the + * exception. Note also that INST_RETURN_STK can proceed to the next + * instruction. + */ + + FWDLABEL( haveOther); + OP4( LOAD_SCALAR, optionsVar); + OP4( LOAD_SCALAR, resultVar); + INVOKE( RETURN_STK); + + /* + * Fix all the jumps from taken clauses to here (which is the end of the + * [try]). + */ + + if (!trapZero) { + FWDLABEL( afterBody); + } + for (i=0 ; i<numHandlers ; i++) { + if (afterReturn0[i] != NO_PENDING_JUMP) { + FWDLABEL( afterReturn0[i]); + } + if (noError[i] != NO_PENDING_JUMP) { + FWDLABEL( noError[i]); + } + } + TclStackFree(interp, afterReturn0); + return TCL_OK; +} + +static int +IssueTryClausesFinallyInstructions( + Tcl_Interp *interp, + CompileEnv *envPtr, + Tcl_Token *bodyToken, + Tcl_Size numHandlers, /* Min 1 */ + TryHandlerInfo *handlers, + Tcl_Token *finallyToken) /* Not NULL */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_LVTIndex resultLocal, optionsLocal; + Tcl_Size i, j, len; + int forwardsNeedFixing = 0, trapZero = 0; + Tcl_ExceptionRange range; + Tcl_BytecodeLabel *addrsToFix, *forwardsToFix; + Tcl_BytecodeLabel finalOK, dontSpliceDuring; + Tcl_BytecodeLabel pushReturnOptions = 0, endCatch = 0, afterBody = 0; + + resultLocal = AnonymousLocal(envPtr); + optionsLocal = AnonymousLocal(envPtr); + if (resultLocal < 0 || optionsLocal < 0) { + return TCL_ERROR; + } /* * Check if we're supposed to trap a normal TCL_OK completion of the body. @@ -3277,7 +3574,7 @@ IssueTryClausesFinallyInstructions( */ for (i=0 ; i<numHandlers ; i++) { - if (matchCodes[i] == 0) { + if (handlers[i].matchCode == 0) { trapZero = 1; break; } @@ -3288,34 +3585,40 @@ IssueTryClausesFinallyInstructions( * (if any trap matches) and run a finally clause. */ - range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); - OP4( BEGIN_CATCH4, range); - ExceptionRangeStarts(envPtr, range); - BODY( bodyToken, 1); - ExceptionRangeEnds(envPtr, range); + range = MAKE_CATCH_RANGE(); + OP4( BEGIN_CATCH, range); + CATCH_RANGE(range) { + BODY( bodyToken, 1); + } if (!trapZero) { - OP( END_CATCH); - STORE( resultVar); - OP( POP); - PUSH( "-level 0 -code 0"); - STORE( optionsVar); - OP( POP); - JUMP4( JUMP, afterBody); + OP( END_CATCH); + OP4( STORE_SCALAR, resultLocal); + OP( POP); + PUSH( "-level 0 -code 0"); + OP4( STORE_SCALAR, optionsLocal); + OP( POP); + FWDJUMP( JUMP, afterBody); } else { - PUSH( "0"); - OP4( REVERSE, 2); - OP1( JUMP1, 4); - TclAdjustStackDepth(-2, envPtr); - } - ExceptionRangeTarget(envPtr, range, catchOffset); - OP( PUSH_RETURN_CODE); - OP( PUSH_RESULT); - OP( PUSH_RETURN_OPTIONS); - OP( END_CATCH); - STORE( optionsVar); - OP( POP); - STORE( resultVar); - OP( POP); + /* + * Fake a return code to go with our result. + */ + PUSH( "0"); + OP( SWAP); + FWDJUMP( JUMP, pushReturnOptions); + STKDELTA(-2); + } + CATCH_TARGET( range); + OP( PUSH_RETURN_CODE); + OP( PUSH_RESULT); + if (pushReturnOptions) { + FWDLABEL( pushReturnOptions); + } + OP( PUSH_RETURN_OPTIONS); + OP( END_CATCH); + OP4( STORE_SCALAR, optionsLocal); + OP( POP); + OP4( STORE_SCALAR, resultLocal); + OP( POP); /* * Now we handle all the registered 'on' and 'trap' handlers in order. @@ -3323,38 +3626,32 @@ IssueTryClausesFinallyInstructions( * Slight overallocation, but reduces size of this function. */ - addrsToFix = (int *)TclStackAlloc(interp, sizeof(int)*numHandlers); - forwardsToFix = (int *)TclStackAlloc(interp, sizeof(int)*numHandlers); + addrsToFix = (Tcl_BytecodeLabel *)TclStackAlloc(interp, + sizeof(Tcl_BytecodeLabel) * numHandlers * 2); + forwardsToFix = addrsToFix + numHandlers; for (i=0 ; i<numHandlers ; i++) { - int noTrapError, trapError; - const char *p; + Tcl_BytecodeLabel codeNotMatched, notErrorCodeMatched = NO_PENDING_JUMP; - snprintf(buf, sizeof(buf), "%d", matchCodes[i]); - OP( DUP); - PushLiteral(envPtr, buf, strlen(buf)); - OP( EQ); - JUMP4( JUMP_FALSE, notCodeJumpSource); - if (matchClauses[i]) { - TclListObjLength(NULL, matchClauses[i], &len); + OP( DUP); + PUSH_OBJ( Tcl_NewIntObj(handlers[i].matchCode)); + OP( EQ); + FWDJUMP( JUMP_FALSE, codeNotMatched); + if (handlers[i].matchClause) { + TclListObjLength(NULL, handlers[i].matchClause, &len); /* * Match the errorcode according to try/trap rules. */ - LOAD( optionsVar); - PUSH( "-errorcode"); - OP4( DICT_GET, 1); - TclAdjustStackDepth(-1, envPtr); - OP44( LIST_RANGE_IMM, 0, len-1); - p = TclGetStringFromObj(matchClauses[i], &slen); - PushLiteral(envPtr, p, slen); - OP( STR_EQ); - JUMP4( JUMP_FALSE, notECJumpSource); - } else { - notECJumpSource = -1; + OP4( LOAD_SCALAR, optionsLocal); + PUSH( "-errorcode"); + OP4( DICT_GET, 1); + PUSH_OBJ( handlers[i].matchClause); + OP4( ERROR_PREFIX_EQ, len); + FWDJUMP( JUMP_FALSE, notErrorCodeMatched); } - OP( POP); + OP( POP); /* * There is a finally clause, so we need a fairly complex sequence of @@ -3363,22 +3660,27 @@ IssueTryClausesFinallyInstructions( * failed trap for the result from the main script. */ - if (resultVars[i] >= 0 || handlerTokens[i]) { - range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); - OP4( BEGIN_CATCH4, range); + if (handlers[i].resultVar != TCL_INDEX_NONE + || handlers[i].optionVar != TCL_INDEX_NONE + || handlers[i].tokenPtr) { + range = MAKE_CATCH_RANGE(); + OP4( BEGIN_CATCH, range); ExceptionRangeStarts(envPtr, range); } - if (resultVars[i] >= 0) { - LOAD( resultVar); - STORE( resultVars[i]); - OP( POP); - if (optionVars[i] >= 0) { - LOAD( optionsVar); - STORE( optionVars[i]); - OP( POP); + if (handlers[i].resultVar != TCL_INDEX_NONE + || handlers[i].optionVar != TCL_INDEX_NONE) { + if (handlers[i].resultVar != TCL_INDEX_NONE) { + OP4( LOAD_SCALAR, resultLocal); + OP4( STORE_SCALAR, handlers[i].resultVar); + OP( POP); + } + if (handlers[i].optionVar != TCL_INDEX_NONE) { + OP4( LOAD_SCALAR, optionsLocal); + OP4( STORE_SCALAR, handlers[i].optionVar); + OP( POP); } - if (!handlerTokens[i]) { + if (!handlers[i].tokenPtr) { /* * No handler. Will not be the last handler (that is a * condition that is checked by the caller). Chain to the next @@ -3386,19 +3688,19 @@ IssueTryClausesFinallyInstructions( */ ExceptionRangeEnds(envPtr, range); - OP( END_CATCH); + OP( END_CATCH); forwardsNeedFixing = 1; - JUMP4( JUMP, forwardsToFix[i]); + FWDJUMP( JUMP, forwardsToFix[i]); goto finishTrapCatchHandling; } - } else if (!handlerTokens[i]) { + } else if (!handlers[i].tokenPtr) { /* * No handler. Will not be the last handler (that condition is * checked by the caller). Chain to the next one. */ forwardsNeedFixing = 1; - JUMP4( JUMP, forwardsToFix[i]); + FWDJUMP( JUMP, forwardsToFix[i]); goto endOfThisArm; } @@ -3409,25 +3711,28 @@ IssueTryClausesFinallyInstructions( */ if (forwardsNeedFixing) { + Tcl_BytecodeLabel bodyStart; forwardsNeedFixing = 0; - OP1( JUMP1, 7); + FWDJUMP( JUMP, bodyStart); for (j=0 ; j<i ; j++) { - if (forwardsToFix[j] == -1) { + if (forwardsToFix[j] == NO_PENDING_JUMP) { continue; } - FIXJUMP4( forwardsToFix[j]); - forwardsToFix[j] = -1; + FWDLABEL(forwardsToFix[j]); + forwardsToFix[j] = NO_PENDING_JUMP; } - OP4( BEGIN_CATCH4, range); + OP4( BEGIN_CATCH, range); + FWDLABEL( bodyStart); } - BODY( handlerTokens[i], 5+i*4); + // TODO: Simplify based on TclIsEmptyToken(handlers[i].tokenPtr) + BODY( handlers[i].tokenPtr, 5 + i*4); ExceptionRangeEnds(envPtr, range); - PUSH( "0"); - OP( PUSH_RETURN_OPTIONS); - OP4( REVERSE, 3); - OP1( JUMP1, 5); - TclAdjustStackDepth(-3, envPtr); - forwardsToFix[i] = -1; + PUSH( "0"); + OP( PUSH_RETURN_OPTIONS); + OP4( REVERSE, 3); + FWDJUMP( JUMP, endCatch); + STKDELTA(-3); + forwardsToFix[i] = NO_PENDING_JUMP; /* * Error in handler or setting of variables; replace the stored @@ -3437,41 +3742,42 @@ IssueTryClausesFinallyInstructions( */ finishTrapCatchHandling: - ExceptionRangeTarget(envPtr, range, catchOffset); - OP( PUSH_RETURN_OPTIONS); - OP( PUSH_RETURN_CODE); - OP( PUSH_RESULT); - OP( END_CATCH); - STORE( resultVar); - OP( POP); - PUSH( "1"); - OP( EQ); - JUMP1( JUMP_FALSE, noTrapError); - LOAD( optionsVar); - PUSH( "-during"); - OP4( REVERSE, 3); - STORE( optionsVar); - OP( POP); - OP44( DICT_SET, 1, optionsVar); - TclAdjustStackDepth(-1, envPtr); - JUMP1( JUMP, trapError); - FIXJUMP1( noTrapError); - STORE( optionsVar); - FIXJUMP1( trapError); + CATCH_TARGET( range); + OP( PUSH_RETURN_OPTIONS); + OP( PUSH_RETURN_CODE); + OP( PUSH_RESULT); + if (endCatch) { + FWDLABEL( endCatch); + } + OP( END_CATCH); + OP4( STORE_SCALAR, resultLocal); + OP( POP); + + PUSH( "1"); + OP( EQ); + FWDJUMP( JUMP_FALSE, dontSpliceDuring); + // Next bit isn't DICT_SET; alter which dict is in optionsLocal + PUSH( "-during"); + OP4( LOAD_SCALAR, optionsLocal); + OP( DICT_PUT); + FWDLABEL( dontSpliceDuring); + + OP4( STORE_SCALAR, optionsLocal); + /* Skip POP at end; can clean up with subsequent POP */ if (i+1 < numHandlers) { - OP( POP); + OP( POP); } endOfThisArm: if (i+1 < numHandlers) { - JUMP4( JUMP, addrsToFix[i]); - TclAdjustStackDepth(1, envPtr); + FWDJUMP( JUMP, addrsToFix[i]); + STKDELTA(+1); } - if (matchClauses[i]) { - FIXJUMP4( notECJumpSource); + if (handlers[i].matchClause) { + FWDLABEL( notErrorCodeMatched); } - FIXJUMP4( notCodeJumpSource); + FWDLABEL( codeNotMatched); } /* @@ -3480,11 +3786,10 @@ IssueTryClausesFinallyInstructions( * (i.e., to the start of the finally clause). */ - OP( POP); + OP( POP); for (i=0 ; i<numHandlers-1 ; i++) { - FIXJUMP4( addrsToFix[i]); + FWDLABEL( addrsToFix[i]); } - TclStackFree(interp, forwardsToFix); TclStackFree(interp, addrsToFix); /* @@ -3496,44 +3801,316 @@ IssueTryClausesFinallyInstructions( */ if (!trapZero) { - FIXJUMP4( afterBody); - } - range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); - OP4( BEGIN_CATCH4, range); - ExceptionRangeStarts(envPtr, range); - BODY( finallyToken, 3 + 4*numHandlers); - ExceptionRangeEnds(envPtr, range); - OP( END_CATCH); - OP( POP); - JUMP1( JUMP, finalOK); - ExceptionRangeTarget(envPtr, range, catchOffset); - OP( PUSH_RESULT); - OP( PUSH_RETURN_OPTIONS); - OP( PUSH_RETURN_CODE); - OP( END_CATCH); - PUSH( "1"); - OP( EQ); - JUMP1( JUMP_FALSE, noFinalError); - LOAD( optionsVar); - PUSH( "-during"); - OP4( REVERSE, 3); - STORE( optionsVar); - OP( POP); - OP44( DICT_SET, 1, optionsVar); - TclAdjustStackDepth(-1, envPtr); - OP( POP); - JUMP1( JUMP, finalError); - TclAdjustStackDepth(1, envPtr); - FIXJUMP1( noFinalError); - STORE( optionsVar); - OP( POP); - FIXJUMP1( finalError); - STORE( resultVar); - OP( POP); - FIXJUMP1( finalOK); - LOAD( optionsVar); - LOAD( resultVar); - INVOKE( RETURN_STK); + FWDLABEL( afterBody); + } + range = MAKE_CATCH_RANGE(); + OP4( BEGIN_CATCH, range); + CATCH_RANGE(range) { + BODY( finallyToken, 3 + 4*numHandlers); + } + OP( END_CATCH); + OP( POP); + FWDJUMP( JUMP, finalOK); + + CATCH_TARGET( range); + OP( PUSH_RESULT); + OP( PUSH_RETURN_OPTIONS); + OP( PUSH_RETURN_CODE); + OP( END_CATCH); + + PUSH( "1"); + OP( EQ); + FWDJUMP( JUMP_FALSE, dontSpliceDuring); + // Next bit isn't DICT_SET; alter which dict is in optionsLocal + PUSH( "-during"); + OP4( LOAD_SCALAR, optionsLocal); + OP( DICT_PUT); + FWDLABEL( dontSpliceDuring); + + OP4( STORE_SCALAR, optionsLocal); + OP( POP); + + OP4( STORE_SCALAR, resultLocal); + OP( POP); + + FWDLABEL( finalOK); + OP4( LOAD_SCALAR, optionsLocal); + OP4( LOAD_SCALAR, resultLocal); + INVOKE( RETURN_STK); + + return TCL_OK; +} + +static int +IssueTryTraplessClausesFinallyInstructions( + Tcl_Interp *interp, + CompileEnv *envPtr, + Tcl_Token *bodyToken, + Tcl_Size numHandlers, /* Min 1 */ + TryHandlerInfo *handlers, + Tcl_Token *finallyToken) /* Not NULL */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_LVTIndex resultLocal, optionsLocal; + Tcl_Size i, j; + int forwardsNeedFixing = 0, trapZero = 0; + Tcl_ExceptionRange range; + Tcl_BytecodeLabel *addrsToFix, *forwardsToFix; + Tcl_BytecodeLabel finalOK, dontSpliceDuring, tableBase, haveOther; + Tcl_BytecodeLabel pushReturnOptions = 0, afterBody = 0; + JumptableNumInfo *tablePtr; + Tcl_AuxDataRef tableIdx; + + resultLocal = AnonymousLocal(envPtr); + optionsLocal = AnonymousLocal(envPtr); + if (resultLocal < 0 || optionsLocal < 0) { + return TCL_ERROR; + } + addrsToFix = (Tcl_BytecodeLabel *)TclStackAlloc(interp, + sizeof(Tcl_BytecodeLabel) * numHandlers * 2); + forwardsToFix = addrsToFix + numHandlers; + for (i=0; i < numHandlers * 2; i++) { + addrsToFix[i] = NO_PENDING_JUMP; + } + tablePtr = AllocJumptableNum(); + tableIdx = RegisterJumptableNum(tablePtr, envPtr); + + /* + * Check if we're supposed to trap a normal TCL_OK completion of the body. + * If not, we can handle that case much more efficiently. + */ + + for (i=0 ; i<numHandlers ; i++) { + if (handlers[i].matchCode == 0) { + trapZero = 1; + break; + } + } + + /* + * Compile the body, trapping any error in it so that we can trap on it + * (if any trap matches) and run a finally clause. + */ + + range = MAKE_CATCH_RANGE(); + OP4( BEGIN_CATCH, range); + CATCH_RANGE(range) { + BODY( bodyToken, 1); + } + if (!trapZero) { + OP( END_CATCH); + OP4( STORE_SCALAR, resultLocal); + OP( POP); + PUSH( "-level 0 -code 0"); + OP4( STORE_SCALAR, optionsLocal); + OP( POP); + FWDJUMP( JUMP, afterBody); + } else { + /* + * Fake a return code to go with our result. + */ + PUSH( "0"); + OP( SWAP); + FWDJUMP( JUMP, pushReturnOptions); + STKDELTA(-2); + } + CATCH_TARGET( range); + OP( PUSH_RETURN_CODE); + OP( PUSH_RESULT); + if (pushReturnOptions) { + FWDLABEL( pushReturnOptions); + } + OP( PUSH_RETURN_OPTIONS); + OP( END_CATCH); + OP4( STORE_SCALAR, optionsLocal); + OP( POP); + OP4( STORE_SCALAR, resultLocal); + OP( POP); + + /* + * Now we handle all the registered 'on' and 'trap' handlers in order. + */ + + BACKLABEL( tableBase); + OP4( JUMP_TABLE_NUM, tableIdx); + FWDJUMP( JUMP, haveOther); + for (i=0 ; i<numHandlers ; i++) { + Tcl_BytecodeLabel endCatch = 0; + CreateJumptableNumEntryToHere(tablePtr, handlers[i].matchCode, tableBase); + + /* + * There is a finally clause, so we need a fairly complex sequence of + * instructions to deal with an on/trap handler because we must call + * the finally handler *and* we need to substitute the result from a + * failed trap for the result from the main script. + */ + + if (handlers[i].resultVar != TCL_INDEX_NONE + || handlers[i].optionVar != TCL_INDEX_NONE + || handlers[i].tokenPtr) { + range = MAKE_CATCH_RANGE(); + OP4( BEGIN_CATCH, range); + ExceptionRangeStarts(envPtr, range); + } + if (handlers[i].resultVar != TCL_INDEX_NONE + || handlers[i].optionVar != TCL_INDEX_NONE) { + if (handlers[i].resultVar != TCL_INDEX_NONE) { + OP4( LOAD_SCALAR, resultLocal); + OP4( STORE_SCALAR, handlers[i].resultVar); + OP( POP); + } + if (handlers[i].optionVar != TCL_INDEX_NONE) { + OP4( LOAD_SCALAR, optionsLocal); + OP4( STORE_SCALAR, handlers[i].optionVar); + OP( POP); + } + + if (!handlers[i].tokenPtr) { + /* + * No handler. Will not be the last handler (that is a + * condition that is checked by the caller). Chain to the next + * one. + */ + + ExceptionRangeEnds(envPtr, range); + OP( END_CATCH); + forwardsNeedFixing = 1; + endCatch = 0; + FWDJUMP( JUMP, forwardsToFix[i]); + goto finishTrapCatchHandling; + } + } else if (!handlers[i].tokenPtr) { + /* + * No handler. Will not be the last handler (that condition is + * checked by the caller). Chain to the next one. + */ + + forwardsNeedFixing = 1; + FWDJUMP( JUMP, forwardsToFix[i]); + goto endOfThisArm; + } + + /* + * Got a handler. Make sure that any pending patch-up actions from + * previous unprocessed handlers are dealt with now that we know where + * they are to jump to. + */ + + if (forwardsNeedFixing) { + Tcl_BytecodeLabel bodyStart; + forwardsNeedFixing = 0; + FWDJUMP( JUMP, bodyStart); + for (j=0 ; j<i ; j++) { + if (forwardsToFix[j] == NO_PENDING_JUMP) { + continue; + } + FWDLABEL(forwardsToFix[j]); + forwardsToFix[j] = NO_PENDING_JUMP; + } + OP4( BEGIN_CATCH, range); + FWDLABEL( bodyStart); + } + // TODO: Simplfy based on TclIsEmptyToken(handlers[i].tokenPtr) + BODY( handlers[i].tokenPtr, 5 + i*4); + ExceptionRangeEnds(envPtr, range); + OP( PUSH_RETURN_OPTIONS); + OP( END_CATCH); + FWDJUMP( JUMP, endCatch); + STKDELTA(-2); + + /* + * Error in handler or setting of variables; replace the stored + * exception with the new one. Note that we only push this if we have + * either a body or some variable setting here. Otherwise this code is + * unreachable. + */ + + finishTrapCatchHandling: + CATCH_TARGET( range); + OP( PUSH_RESULT); + OP( PUSH_RETURN_OPTIONS); + OP( PUSH_RETURN_CODE); + OP( END_CATCH); + + PUSH( "1"); + OP( EQ); + FWDJUMP( JUMP_FALSE, dontSpliceDuring); + // Next bit isn't DICT_SET; alter which dict is in optionsLocal + PUSH( "-during"); + OP4( LOAD_SCALAR, optionsLocal); + OP( DICT_PUT); + FWDLABEL( dontSpliceDuring); + + if (endCatch) { + FWDLABEL( endCatch); + } + OP4( STORE_SCALAR, optionsLocal); + OP( POP); + OP4( STORE_SCALAR, resultLocal); + OP( POP); + + endOfThisArm: + if (i+1 < numHandlers) { + FWDJUMP( JUMP, addrsToFix[i]); + } + } + + /* + * Fix all the jumps from taken clauses and the jump from after the jump + * table to point to the start of the finally processing. + */ + + for (i=0 ; i<numHandlers-1 ; i++) { + FWDLABEL( addrsToFix[i]); + } + TclStackFree(interp, addrsToFix); + FWDLABEL( haveOther); + if (!trapZero) { + FWDLABEL( afterBody); + } + + /* + * Process the finally clause (at last!) Note that we do not wrap this in + * error handlers because we would just rethrow immediately anyway. Then + * (on normal success) we reissue the exception. Note also that + * INST_RETURN_STK can proceed to the next instruction; that'll be the + * next command (or some inter-command manipulation). + */ + + range = MAKE_CATCH_RANGE(); + OP4( BEGIN_CATCH, range); + CATCH_RANGE(range) { + BODY( finallyToken, 3 + 4*numHandlers); + } + OP( END_CATCH); + OP( POP); + FWDJUMP( JUMP, finalOK); + + CATCH_TARGET( range); + OP( PUSH_RESULT); + OP( PUSH_RETURN_OPTIONS); + OP( PUSH_RETURN_CODE); + OP( END_CATCH); + + PUSH( "1"); + OP( EQ); + FWDJUMP( JUMP_FALSE, dontSpliceDuring); + // Next bit isn't DICT_SET; alter which dict is in optionsLocal + PUSH( "-during"); + OP4( LOAD_SCALAR, optionsLocal); + OP( DICT_PUT); + FWDLABEL( dontSpliceDuring); + + OP4( STORE_SCALAR, optionsLocal); + OP( POP); + + OP4( STORE_SCALAR, resultLocal); + OP( POP); + + FWDLABEL( finalOK); + OP4( LOAD_SCALAR, optionsLocal); + OP4( LOAD_SCALAR, resultLocal); + INVOKE( RETURN_STK); return TCL_OK; } @@ -3546,53 +4123,65 @@ IssueTryFinallyInstructions( Tcl_Token *finallyToken) { DefineLineInformation; /* TIP #280 */ - int range, jumpOK, jumpSplice; + Tcl_ExceptionRange bodyRange, finallyRange; + Tcl_BytecodeLabel jumpOK, dontSpliceDuring, endCatch; /* * Note that this one is simple enough that we can issue it without * needing a local variable table, making it a universal compilation. */ - range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); - OP4( BEGIN_CATCH4, range); - ExceptionRangeStarts(envPtr, range); - BODY( bodyToken, 1); - ExceptionRangeEnds(envPtr, range); - OP1( JUMP1, 3); - TclAdjustStackDepth(-1, envPtr); - ExceptionRangeTarget(envPtr, range, catchOffset); - OP( PUSH_RESULT); - OP( PUSH_RETURN_OPTIONS); - OP( END_CATCH); - - range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); - OP4( BEGIN_CATCH4, range); - ExceptionRangeStarts(envPtr, range); - BODY( finallyToken, 3); - ExceptionRangeEnds(envPtr, range); - OP( END_CATCH); - OP( POP); - JUMP1( JUMP, jumpOK); - ExceptionRangeTarget(envPtr, range, catchOffset); - OP( PUSH_RESULT); - OP( PUSH_RETURN_OPTIONS); - OP( PUSH_RETURN_CODE); - OP( END_CATCH); - PUSH( "1"); - OP( EQ); - JUMP1( JUMP_FALSE, jumpSplice); - PUSH( "-during"); - OP4( OVER, 3); - OP4( LIST, 2); - OP( LIST_CONCAT); - FIXJUMP1( jumpSplice); - OP4( REVERSE, 4); - OP( POP); - OP( POP); - OP1( JUMP1, 7); - FIXJUMP1( jumpOK); - OP4( REVERSE, 2); - INVOKE( RETURN_STK); + bodyRange = MAKE_CATCH_RANGE(); + + // Body + OP4( BEGIN_CATCH, bodyRange); + CATCH_RANGE(bodyRange) { + BODY( bodyToken, 1); + } + FWDJUMP( JUMP, endCatch); + STKDELTA(-1); + + CATCH_TARGET( bodyRange); + OP( PUSH_RESULT); + FWDLABEL( endCatch); + // Cannot avoid this next op: test-case error-15.9.0.0.2 + OP( PUSH_RETURN_OPTIONS); + OP( END_CATCH); + + // Finally + finallyRange = MAKE_CATCH_RANGE(); + OP4( BEGIN_CATCH, finallyRange); + CATCH_RANGE(finallyRange) { + BODY( finallyToken, 3); + } + OP( END_CATCH); + OP( POP); + OP( SWAP); + FWDJUMP( JUMP, jumpOK); + + CATCH_TARGET( finallyRange); + OP( PUSH_RESULT); + OP( PUSH_RETURN_OPTIONS); + OP( PUSH_RETURN_CODE); + OP( END_CATCH); + + // Don't forget original error + PUSH( "1"); + OP( EQ); + FWDJUMP( JUMP_FALSE, dontSpliceDuring); + PUSH( "-during"); + OP4( OVER, 3); + OP( DICT_PUT); + FWDLABEL( dontSpliceDuring); + + OP4( REVERSE, 4); + OP( POP); + OP( POP); + + // Re-raise + FWDLABEL( jumpOK); + // Cannot avoid this next op: test-case error-15.9.0.0.2 + INVOKE( RETURN_STK); return TCL_OK; } @@ -3624,17 +4213,23 @@ TclCompileUnsetCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr; - int isScalar, localIndex, flags = 1, i, varCount = 0, haveFlags = 0; + int isScalar, flags = 1; + Tcl_Size haveFlags = 0, i, varCount = 0; + Tcl_LVTIndex localIndex; /* TODO: Consider support for compiling expanded args. */ + if (parsePtr->numWords > UINT_MAX) { + return TCL_ERROR; + } + /* * Verify that all words - except the first non-option one - are known at * compile time so that we can handle them without needing to do a nasty * push/rotate. [Bug 3970f54c4e] */ - for (i=1,varTokenPtr=parsePtr->tokenPtr ; i<(int)parsePtr->numWords ; i++) { + for (i=1,varTokenPtr=parsePtr->tokenPtr ; i<parsePtr->numWords ; i++) { Tcl_Obj *leadingWord; TclNewObj(leadingWord); @@ -3698,7 +4293,7 @@ TclCompileUnsetCmd( for (i=0; i<haveFlags;i++) { varTokenPtr = TokenAfter(varTokenPtr); } - for (i=1+haveFlags ; i<(int)parsePtr->numWords ; i++) { + for (i=1+haveFlags ; i<parsePtr->numWords ; i++) { /* * Decide if we can use a frame slot for the var/array name or if we * need to emit code to compute and push the name at runtime. We use a @@ -3707,8 +4302,7 @@ TclCompileUnsetCmd( * namespace qualifiers. */ - PushVarNameWord(interp, varTokenPtr, envPtr, 0, - &localIndex, &isScalar, i); + PushVarNameWord(varTokenPtr, 0, &localIndex, &isScalar, i); /* * Emit instructions to unset the variable. @@ -3716,21 +4310,110 @@ TclCompileUnsetCmd( if (isScalar) { if (localIndex < 0) { - OP1( UNSET_STK, flags); + OP1( UNSET_STK, flags); } else { - OP14( UNSET_SCALAR, flags, localIndex); + OP14( UNSET_SCALAR, flags, localIndex); } } else { if (localIndex < 0) { - OP1( UNSET_ARRAY_STK, flags); + OP1( UNSET_ARRAY_STK, flags); } else { - OP14( UNSET_ARRAY, flags, localIndex); + OP14( UNSET_ARRAY, flags, localIndex); } } varTokenPtr = TokenAfter(varTokenPtr); } - PUSH(""); + PUSH( ""); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileUplevelCmd -- + * + * Procedure called to compile the "uplevel" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "uplevel" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileUplevelCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + TCL_UNUSED(Command *), + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Size numWords = parsePtr->numWords; + Tcl_Token *tokenPtr; + Tcl_Obj *objPtr; + Tcl_Size i, first; + + /* TODO: Consider support for compiling expanded args. */ + if (numWords < 2 || numWords > 1<<8 || !EnvIsProc(envPtr)) { + /* + * The limit on the max number of words is arbitrary; could be higher, + * but I doubt we'll ever hit it anyway. + */ + return TCL_ERROR; + } + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + TclNewObj(objPtr); + if (!TclWordKnownAtCompileTime(tokenPtr, objPtr)) { + /* + * If the first argument isn't known at compile time, we can't know if + * it is a script fragment or a level descriptor. Punt. + */ + Tcl_DecrRefCount(objPtr); + return TCL_ERROR; + } + + /* + * Attempt to convert to a level reference. Note that TclObjGetFrame + * only changes the obj type when a conversion was successful. + */ + + int numFrameWords = TclObjGetFrame(interp, objPtr, NULL); + Tcl_DecrRefCount(objPtr); + if (numFrameWords < 0) { + return TCL_ERROR; + } + + if (numFrameWords) { + PUSH_TOKEN( tokenPtr, 1); + tokenPtr = TokenAfter(tokenPtr); + first = 2; + } else { + PUSH( "1"); + first = 1; + } + if (first >= numWords) { + // In this case, there's ambiguity about sole argument meaning. + return TCL_ERROR; + } + + // Push all remaining words and concatenate them to make a single script word + for (i=first; i<numWords; i++, tokenPtr=TokenAfter(tokenPtr)) { + PUSH_TOKEN( tokenPtr, i); + } + if (numWords - first > 1) { + OP4( CONCAT_STK, numWords - first); + } + + // Do the actual uplevel operation. + INVOKE( UPLEVEL); return TCL_OK; } @@ -3762,8 +4445,9 @@ TclCompileWhileCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *testTokenPtr, *bodyTokenPtr; - JumpFixup jumpEvalCondFixup; - int testCodeOffset, bodyCodeOffset, jumpDist, range, code, boolVal; + Tcl_BytecodeLabel jumpEvalCond, bodyCodeOffset; + Tcl_ExceptionRange range; + int code, boolVal; int loopMayEnd = 1; /* This is set to 0 if it is recognized as an * infinite loop. */ Tcl_Obj *boolObj; @@ -3784,8 +4468,12 @@ TclCompileWhileCmd( testTokenPtr = TokenAfter(parsePtr->tokenPtr); bodyTokenPtr = TokenAfter(testTokenPtr); - if ((testTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) - || (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)) { + if (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + return TCL_ERROR; + } + TclNewObj(boolObj); + if (!TclWordKnownAtCompileTime(testTokenPtr, boolObj)) { + Tcl_BounceRefCount(boolObj); return TCL_ERROR; } @@ -3793,10 +4481,8 @@ TclCompileWhileCmd( * Find out if the condition is a constant. */ - boolObj = Tcl_NewStringObj(testTokenPtr[1].start, testTokenPtr[1].size); - Tcl_IncrRefCount(boolObj); code = Tcl_GetBooleanFromObj(NULL, boolObj, &boolVal); - TclDecrRefCount(boolObj); + Tcl_BounceRefCount(boolObj); if (code == TCL_OK) { if (boolVal) { /* @@ -3820,7 +4506,7 @@ TclCompileWhileCmd( * implement break and continue. */ - range = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); + range = MAKE_LOOP_RANGE(); /* * Jump to the evaluation of the condition. This code uses the "loop @@ -3837,9 +4523,7 @@ TclCompileWhileCmd( */ if (loopMayEnd) { - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, - &jumpEvalCondFixup); - testCodeOffset = 0; /* Avoid compiler warning. */ + FWDJUMP( JUMP, jumpEvalCond); } else { /* * Make sure that the first command in the body is preceded by an @@ -3847,21 +4531,18 @@ TclCompileWhileCmd( */ envPtr->atCmdStart &= ~1; - testCodeOffset = CurrentOffset(envPtr); + CONTINUE_TARGET(range); } /* * Compile the loop body. */ - bodyCodeOffset = ExceptionRangeStarts(envPtr, range); - if (!loopMayEnd) { - envPtr->exceptArrayPtr[range].continueOffset = testCodeOffset; - envPtr->exceptArrayPtr[range].codeOffset = bodyCodeOffset; + BACKLABEL( bodyCodeOffset); + CATCH_RANGE(range) { + BODY( bodyTokenPtr, 2); } - BODY(bodyTokenPtr, 2); - ExceptionRangeEnds(envPtr, range); - OP( POP); + OP( POP); /* * Compile the test expression then emit the conditional jump that @@ -3869,45 +4550,27 @@ TclCompileWhileCmd( */ if (loopMayEnd) { - testCodeOffset = CurrentOffset(envPtr); - jumpDist = testCodeOffset - jumpEvalCondFixup.codeOffset; - if (TclFixupForwardJump(envPtr, &jumpEvalCondFixup, jumpDist, 127)) { - bodyCodeOffset += 3; - testCodeOffset += 3; - } - SetLineInformation(1); - TclCompileExprWords(interp, testTokenPtr, 1, envPtr); - - jumpDist = CurrentOffset(envPtr) - bodyCodeOffset; - if (jumpDist > 127) { - TclEmitInstInt4(INST_JUMP_TRUE4, -jumpDist, envPtr); - } else { - TclEmitInstInt1(INST_JUMP_TRUE1, -jumpDist, envPtr); - } + FWDLABEL( jumpEvalCond); + CONTINUE_TARGET(range); + PUSH_EXPR_TOKEN( testTokenPtr, 1); + BACKJUMP( JUMP_TRUE, bodyCodeOffset); } else { - jumpDist = CurrentOffset(envPtr) - bodyCodeOffset; - if (jumpDist > 127) { - TclEmitInstInt4(INST_JUMP4, -jumpDist, envPtr); - } else { - TclEmitInstInt1(INST_JUMP1, -jumpDist, envPtr); - } + BACKJUMP( JUMP, bodyCodeOffset); } /* - * Set the loop's body, continue and break offsets. + * Set the loop's break offset. */ - envPtr->exceptArrayPtr[range].continueOffset = testCodeOffset; - envPtr->exceptArrayPtr[range].codeOffset = bodyCodeOffset; - ExceptionRangeTarget(envPtr, range, breakOffset); - TclFinalizeLoopExceptionRange(envPtr, range); + BREAK_TARGET( range); + FINALIZE_LOOP(range); /* * The while command's result is an empty string. */ pushResult: - PUSH(""); + PUSH( ""); return TCL_OK; } @@ -3942,14 +4605,14 @@ TclCompileYieldCmd( } if (parsePtr->numWords == 1) { - PUSH(""); + PUSH( ""); } else { DefineLineInformation; /* TIP #280 */ Tcl_Token *valueTokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, valueTokenPtr, interp, 1); + PUSH_TOKEN( valueTokenPtr, 1); } - OP( YIELD); + INVOKE( YIELD); return TCL_OK; } @@ -3981,19 +4644,46 @@ TclCompileYieldToCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); - int i; - - if ((int)parsePtr->numWords < 2) { - return TCL_ERROR; - } - - OP( NS_CURRENT); - for (i = 1 ; i < (int)parsePtr->numWords ; i++) { - CompileWord(envPtr, tokenPtr, interp, i); + Tcl_Size i, numWords = parsePtr->numWords, build; + int concat = 0; + + OP( NS_CURRENT); + for (build = i = 1; i < numWords; i++) { + if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD && build > 0) { + OP4( LIST, build); + if (concat) { + OP( LIST_CONCAT); + } + build = 0; + concat = 1; + } + PUSH_TOKEN( tokenPtr, i); + if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { + if (concat) { + OP( LIST_CONCAT); + } else { + concat = 1; + } + } else { + build++; + } + if (build > LIST_CONCAT_THRESHOLD) { + OP4( LIST, build); + if (concat) { + OP( LIST_CONCAT); + } + build = 0; + concat = 1; + } tokenPtr = TokenAfter(tokenPtr); } - OP4( LIST, i); - OP( YIELD_TO_INVOKE); + if (build > 0) { + OP4( LIST, build); + if (concat) { + OP( LIST_CONCAT); + } + } + INVOKE( YIELD_TO_INVOKE); return TCL_OK; } @@ -4029,7 +4719,7 @@ CompileUnaryOpCmd( return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); + PUSH_TOKEN( tokenPtr, 1); TclEmitOpcode(instruction, envPtr); return TCL_OK; } @@ -4069,12 +4759,15 @@ CompileAssociativeBinaryOpCmd( Tcl_Size words; /* TODO: Consider support for compiling expanded args. */ + if (parsePtr->numWords > UINT_MAX) { + return TCL_ERROR; + } for (words=1 ; words<parsePtr->numWords ; words++) { tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, words); + PUSH_TOKEN( tokenPtr, words); } if (parsePtr->numWords <= 2) { - PushLiteral(envPtr, identity, -1); + PUSH_STRING( identity); words++; } if (words > 3) { @@ -4083,7 +4776,7 @@ CompileAssociativeBinaryOpCmd( * calculations, including roundoff errors. */ - OP4( REVERSE, words-1); + OP4( REVERSE, words - 1); } while (--words > 1) { TclEmitOpcode(instruction, envPtr); @@ -4153,41 +4846,44 @@ CompileComparisonOpCmd( Tcl_Token *tokenPtr; /* TODO: Consider support for compiling expanded args. */ - if ((int)parsePtr->numWords < 3) { - PUSH("1"); + if (parsePtr->numWords > UINT_MAX) { + return TCL_ERROR; + } + if (parsePtr->numWords < 3) { + PUSH( "1"); } else if (parsePtr->numWords == 3) { tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); + PUSH_TOKEN( tokenPtr, 1); tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 2); + PUSH_TOKEN( tokenPtr, 2); TclEmitOpcode(instruction, envPtr); - } else if (envPtr->procPtr == NULL) { + } else if (!EnvIsProc(envPtr)) { /* * No local variable space! */ return TCL_ERROR; } else { - int tmpIndex = AnonymousLocal(envPtr); + Tcl_LVTIndex tmpIndex = AnonymousLocal(envPtr); Tcl_Size words; tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); + PUSH_TOKEN( tokenPtr, 1); tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 2); - STORE(tmpIndex); + PUSH_TOKEN( tokenPtr, 2); + OP4( STORE_SCALAR, tmpIndex); TclEmitOpcode(instruction, envPtr); for (words=3 ; words<parsePtr->numWords ;) { - LOAD(tmpIndex); + OP4( LOAD_SCALAR, tmpIndex); tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, words); + PUSH_TOKEN( tokenPtr, words); if (++words < parsePtr->numWords) { - STORE(tmpIndex); + OP4( STORE_SCALAR, tmpIndex); } TclEmitOpcode(instruction, envPtr); } for (; words>3 ; words--) { - OP( BITAND); + OP( BITAND); } /* @@ -4195,7 +4891,7 @@ CompileComparisonOpCmd( * might be expensive elsewhere. */ - OP14( UNSET_SCALAR, 0, tmpIndex); + OP14( UNSET_SCALAR, 0, tmpIndex); } return TCL_OK; } @@ -4307,6 +5003,10 @@ TclCompilePowOpCmd( Tcl_Token *tokenPtr = parsePtr->tokenPtr; Tcl_Size words; + if (parsePtr->numWords > UINT_MAX) { + return TCL_ERROR; + } + /* * This one has its own implementation because the ** operator is the only * one with right associativity. @@ -4314,14 +5014,14 @@ TclCompilePowOpCmd( for (words=1 ; words<parsePtr->numWords ; words++) { tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, words); + PUSH_TOKEN( tokenPtr, words); } if (parsePtr->numWords <= 2) { - PUSH("1"); + PUSH( "1"); words++; } while (--words > 1) { - TclEmitOpcode(INST_EXPON, envPtr); + OP( EXPON); } return TCL_OK; } @@ -4509,7 +5209,7 @@ TclCompileMinusOpCmd( Tcl_Size words; /* TODO: Consider support for compiling expanded args. */ - if (parsePtr->numWords == 1) { + if (parsePtr->numWords == 1 || parsePtr->numWords > UINT_MAX) { /* * Fallback to direct eval to report syntax error. */ @@ -4518,14 +5218,14 @@ TclCompileMinusOpCmd( } for (words=1 ; words<parsePtr->numWords ; words++) { tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, words); + PUSH_TOKEN( tokenPtr, words); } if (words == 2) { - TclEmitOpcode(INST_UMINUS, envPtr); + OP( UMINUS); return TCL_OK; } if (words == 3) { - TclEmitOpcode(INST_SUB, envPtr); + OP( SUB); return TCL_OK; } @@ -4534,10 +5234,10 @@ TclCompileMinusOpCmd( * calculations, including roundoff errors. */ - TclEmitInstInt4(INST_REVERSE, words-1, envPtr); + OP4( REVERSE, words - 1); while (--words > 1) { - TclEmitInstInt4(INST_REVERSE, 2, envPtr); - TclEmitOpcode(INST_SUB, envPtr); + OP( SWAP); + OP( SUB); } return TCL_OK; } @@ -4554,7 +5254,7 @@ TclCompileDivOpCmd( Tcl_Size words; /* TODO: Consider support for compiling expanded args. */ - if (parsePtr->numWords == 1) { + if (parsePtr->numWords == 1 || parsePtr->numWords > UINT_MAX) { /* * Fallback to direct eval to report syntax error. */ @@ -4562,14 +5262,14 @@ TclCompileDivOpCmd( return TCL_ERROR; } if (parsePtr->numWords == 2) { - PUSH("1.0"); + PUSH( "1.0"); } for (words=1 ; words<parsePtr->numWords ; words++) { tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, words); + PUSH_TOKEN( tokenPtr, words); } if (words <= 3) { - TclEmitOpcode(INST_DIV, envPtr); + OP( DIV); return TCL_OK; } @@ -4578,10 +5278,10 @@ TclCompileDivOpCmd( * calculations, including roundoff errors. */ - TclEmitInstInt4(INST_REVERSE, words-1, envPtr); + OP4( REVERSE, words - 1); while (--words > 1) { - TclEmitInstInt4(INST_REVERSE, 2, envPtr); - TclEmitOpcode(INST_DIV, envPtr); + OP( SWAP); + OP( DIV); } return TCL_OK; } diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index ff03f87..d0042a0 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -61,11 +61,11 @@ typedef struct { */ enum OperandTypes { - OT_LITERAL = -3, /* Operand is a literal in the literal list */ - OT_TOKENS = -2, /* Operand is sequence of Tcl_Tokens */ - OT_EMPTY = -1 /* "Operand" is an empty string. This is a special - * case used only to represent the EMPTY lexeme. See - * below. */ + OT_LITERAL = -3, /* Operand is a literal in the literal list */ + OT_TOKENS = -2, /* Operand is sequence of Tcl_Tokens */ + OT_EMPTY = -1 /* "Operand" is an empty string. This is a + * special case used only to represent the + * EMPTY lexeme. See below. */ }; /* @@ -106,9 +106,9 @@ enum OperandTypes { */ enum Marks { - MARK_LEFT, /* Next step of traversal is to visit left subtree */ - MARK_RIGHT, /* Next step of traversal is to visit right subtree */ - MARK_PARENT /* Next step of traversal is to return to parent */ + MARK_LEFT, /* Next step of traversal is to visit left subtree */ + MARK_RIGHT, /* Next step of traversal is to visit right subtree */ + MARK_PARENT /* Next step of traversal is to return to parent */ }; /* @@ -162,7 +162,7 @@ enum LexemeCodes { * FUNCTION or a parse error according to * context and value. */ INCOMPLETE = 4, /* A parse error. Used only when the single - * "=" is encountered. */ + * "=" is encountered. */ INVALID = 5, /* A parse error. Used when any punctuation * appears that's not a supported operator. */ COMMENT = 6, /* Comment. Lasts to end of line or end of @@ -223,7 +223,7 @@ enum LexemeCodes { * that this operator can only legally appear * at the right places within a function call * argument list are hard coded within - * ParseExpr(). */ + * ParseExpr(). */ MULT = BINARY | 4, DIVIDE = BINARY | 5, MOD = BINARY | 6, @@ -292,24 +292,24 @@ enum LexemeCodes { */ enum Precedence { - PREC_END = 1, /* END */ - PREC_START, /* START */ - PREC_CLOSE_PAREN, /* ")" */ - PREC_OPEN_PAREN, /* "(" */ - PREC_COMMA, /* "," */ - PREC_CONDITIONAL, /* "?", ":" */ - PREC_OR, /* "||" */ - PREC_AND, /* "&&" */ - PREC_BIT_OR, /* "|" */ - PREC_BIT_XOR, /* "^" */ - PREC_BIT_AND, /* "&" */ - PREC_EQUAL, /* "==", "!=", "eq", "ne", "in", "ni" */ - PREC_COMPARE, /* "<", ">", "<=", ">=" */ - PREC_SHIFT, /* "<<", ">>" */ - PREC_ADD, /* "+", "-" */ - PREC_MULT, /* "*", "/", "%" */ - PREC_EXPON, /* "**" */ - PREC_UNARY /* "+", "-", FUNCTION, "!", "~" */ + PREC_END = 1, /* END */ + PREC_START, /* START */ + PREC_CLOSE_PAREN, /* ")" */ + PREC_OPEN_PAREN, /* "(" */ + PREC_COMMA, /* "," */ + PREC_CONDITIONAL, /* "?", ":" */ + PREC_OR, /* "||" */ + PREC_AND, /* "&&" */ + PREC_BIT_OR, /* "|" */ + PREC_BIT_XOR, /* "^" */ + PREC_BIT_AND, /* "&" */ + PREC_EQUAL, /* "==", "!=", "eq", "ne", "in", "ni" */ + PREC_COMPARE, /* "<", ">", "<=", ">=" */ + PREC_SHIFT, /* "<<", ">>" */ + PREC_ADD, /* "+", "-" */ + PREC_MULT, /* "*", "/", "%" */ + PREC_EXPON, /* "**" */ + PREC_UNARY /* "+", "-", FUNCTION, "!", "~" */ }; /* @@ -326,49 +326,49 @@ static const unsigned char prec[] = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* Binary operator lexemes */ - PREC_ADD, /* BINARY_PLUS */ - PREC_ADD, /* BINARY_MINUS */ - PREC_COMMA, /* COMMA */ - PREC_MULT, /* MULT */ - PREC_MULT, /* DIVIDE */ - PREC_MULT, /* MOD */ - PREC_COMPARE, /* LESS */ - PREC_COMPARE, /* GREATER */ - PREC_BIT_AND, /* BIT_AND */ - PREC_BIT_XOR, /* BIT_XOR */ - PREC_BIT_OR, /* BIT_OR */ - PREC_CONDITIONAL, /* QUESTION */ - PREC_CONDITIONAL, /* COLON */ - PREC_SHIFT, /* LEFT_SHIFT */ - PREC_SHIFT, /* RIGHT_SHIFT */ - PREC_COMPARE, /* LEQ */ - PREC_COMPARE, /* GEQ */ - PREC_EQUAL, /* EQUAL */ - PREC_EQUAL, /* NEQ */ - PREC_AND, /* AND */ - PREC_OR, /* OR */ - PREC_EQUAL, /* STREQ */ - PREC_EQUAL, /* STRNEQ */ - PREC_EXPON, /* EXPON */ - PREC_EQUAL, /* IN_LIST */ - PREC_EQUAL, /* NOT_IN_LIST */ - PREC_CLOSE_PAREN, /* CLOSE_PAREN */ - PREC_COMPARE, /* STR_LT */ - PREC_COMPARE, /* STR_GT */ - PREC_COMPARE, /* STR_LEQ */ - PREC_COMPARE, /* STR_GEQ */ - PREC_END, /* END */ + PREC_ADD, /* BINARY_PLUS */ + PREC_ADD, /* BINARY_MINUS */ + PREC_COMMA, /* COMMA */ + PREC_MULT, /* MULT */ + PREC_MULT, /* DIVIDE */ + PREC_MULT, /* MOD */ + PREC_COMPARE, /* LESS */ + PREC_COMPARE, /* GREATER */ + PREC_BIT_AND, /* BIT_AND */ + PREC_BIT_XOR, /* BIT_XOR */ + PREC_BIT_OR, /* BIT_OR */ + PREC_CONDITIONAL, /* QUESTION */ + PREC_CONDITIONAL, /* COLON */ + PREC_SHIFT, /* LEFT_SHIFT */ + PREC_SHIFT, /* RIGHT_SHIFT */ + PREC_COMPARE, /* LEQ */ + PREC_COMPARE, /* GEQ */ + PREC_EQUAL, /* EQUAL */ + PREC_EQUAL, /* NEQ */ + PREC_AND, /* AND */ + PREC_OR, /* OR */ + PREC_EQUAL, /* STREQ */ + PREC_EQUAL, /* STRNEQ */ + PREC_EXPON, /* EXPON */ + PREC_EQUAL, /* IN_LIST */ + PREC_EQUAL, /* NOT_IN_LIST */ + PREC_CLOSE_PAREN, /* CLOSE_PAREN */ + PREC_COMPARE, /* STR_LT */ + PREC_COMPARE, /* STR_GT */ + PREC_COMPARE, /* STR_LEQ */ + PREC_COMPARE, /* STR_GEQ */ + PREC_END, /* END */ /* Expansion room for more binary operators */ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* Unary operator lexemes */ - PREC_UNARY, /* UNARY_PLUS */ - PREC_UNARY, /* UNARY_MINUS */ - PREC_UNARY, /* FUNCTION */ - PREC_START, /* START */ - PREC_OPEN_PAREN, /* OPEN_PAREN */ - PREC_UNARY, /* NOT*/ - PREC_UNARY, /* BIT_NOT*/ + PREC_UNARY, /* UNARY_PLUS */ + PREC_UNARY, /* UNARY_MINUS */ + PREC_UNARY, /* FUNCTION */ + PREC_START, /* START */ + PREC_OPEN_PAREN, /* OPEN_PAREN */ + PREC_UNARY, /* NOT*/ + PREC_UNARY, /* BIT_NOT*/ }; /* @@ -383,49 +383,49 @@ static const unsigned char instruction[] = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* Binary operator lexemes */ - INST_ADD, /* BINARY_PLUS */ - INST_SUB, /* BINARY_MINUS */ - 0, /* COMMA */ - INST_MULT, /* MULT */ - INST_DIV, /* DIVIDE */ - INST_MOD, /* MOD */ - INST_LT, /* LESS */ - INST_GT, /* GREATER */ - INST_BITAND, /* BIT_AND */ - INST_BITXOR, /* BIT_XOR */ - INST_BITOR, /* BIT_OR */ - 0, /* QUESTION */ - 0, /* COLON */ - INST_LSHIFT, /* LEFT_SHIFT */ - INST_RSHIFT, /* RIGHT_SHIFT */ - INST_LE, /* LEQ */ - INST_GE, /* GEQ */ - INST_EQ, /* EQUAL */ - INST_NEQ, /* NEQ */ - 0, /* AND */ - 0, /* OR */ - INST_STR_EQ, /* STREQ */ - INST_STR_NEQ, /* STRNEQ */ - INST_EXPON, /* EXPON */ - INST_LIST_IN, /* IN_LIST */ - INST_LIST_NOT_IN, /* NOT_IN_LIST */ - 0, /* CLOSE_PAREN */ - INST_STR_LT, /* STR_LT */ - INST_STR_GT, /* STR_GT */ - INST_STR_LE, /* STR_LEQ */ - INST_STR_GE, /* STR_GEQ */ - 0, /* END */ + INST_ADD, /* BINARY_PLUS */ + INST_SUB, /* BINARY_MINUS */ + 0, /* COMMA */ + INST_MULT, /* MULT */ + INST_DIV, /* DIVIDE */ + INST_MOD, /* MOD */ + INST_LT, /* LESS */ + INST_GT, /* GREATER */ + INST_BITAND, /* BIT_AND */ + INST_BITXOR, /* BIT_XOR */ + INST_BITOR, /* BIT_OR */ + 0, /* QUESTION */ + 0, /* COLON */ + INST_LSHIFT, /* LEFT_SHIFT */ + INST_RSHIFT, /* RIGHT_SHIFT */ + INST_LE, /* LEQ */ + INST_GE, /* GEQ */ + INST_EQ, /* EQUAL */ + INST_NEQ, /* NEQ */ + 0, /* AND */ + 0, /* OR */ + INST_STR_EQ, /* STREQ */ + INST_STR_NEQ, /* STRNEQ */ + INST_EXPON, /* EXPON */ + INST_LIST_IN, /* IN_LIST */ + INST_LIST_NOT_IN, /* NOT_IN_LIST */ + 0, /* CLOSE_PAREN */ + INST_STR_LT, /* STR_LT */ + INST_STR_GT, /* STR_GT */ + INST_STR_LE, /* STR_LEQ */ + INST_STR_GE, /* STR_GEQ */ + 0, /* END */ /* Expansion room for more binary operators */ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* Unary operator lexemes */ - INST_UPLUS, /* UNARY_PLUS */ - INST_UMINUS, /* UNARY_MINUS */ - 0, /* FUNCTION */ - 0, /* START */ - 0, /* OPEN_PAREN */ - INST_LNOT, /* NOT*/ - INST_BITNOT, /* BIT_NOT*/ + INST_UPLUS, /* UNARY_PLUS */ + INST_UMINUS, /* UNARY_MINUS */ + 0, /* FUNCTION */ + 0, /* START */ + 0, /* OPEN_PAREN */ + INST_LNOT, /* NOT*/ + INST_BITNOT, /* BIT_NOT*/ }; /* @@ -721,7 +721,7 @@ ParseExpr( * is a legal literal boolean value, we accept that as well. */ - if (start[scanned+TclParseAllWhiteSpace( + if (literal && start[scanned+TclParseAllWhiteSpace( start+scanned, numBytes-scanned)] == '(') { lexeme = FUNCTION; @@ -733,14 +733,14 @@ ParseExpr( */ Tcl_ListObjAppendElement(NULL, funcList, literal); - } else if (Tcl_GetBooleanFromObj(NULL,literal,&b) == TCL_OK) { + } else if (literal && Tcl_GetBooleanFromObj(NULL,literal,&b) == TCL_OK) { lexeme = BOOL_LIT; } else { /* * Tricky case: see test expr-62.10 */ - int scanned2 = scanned; + Tcl_Size scanned2 = scanned; do { scanned2 += TclParseAllWhiteSpace( start + scanned2, numBytes - scanned2); @@ -748,7 +748,7 @@ ParseExpr( start + scanned2, numBytes - scanned2, &lexeme, NULL); } while (lexeme == COMMENT); - if (lexeme == OPEN_PAREN) { + if (literal && lexeme == OPEN_PAREN) { /* * Actually a function call, but with obscuring * comments. Skip to the start of the parentheses. @@ -762,7 +762,9 @@ ParseExpr( break; } - Tcl_DecrRefCount(literal); + if (literal) { + Tcl_DecrRefCount(literal); + } msg = Tcl_ObjPrintf("invalid bareword \"%.*s%s\"", (int)((scanned < limit) ? scanned : limit - 3), start, (scanned < limit) ? "" : "..."); @@ -785,14 +787,16 @@ ParseExpr( switch (start[1]) { case 'b': Tcl_AppendToObj(post, - " (invalid binary number?)", -1); + " (invalid binary number?)", + TCL_AUTO_LENGTH); parsePtr->errorType = TCL_PARSE_BAD_NUMBER; errCode = "BADNUMBER"; subErrCode = "BINARY"; break; case 'o': Tcl_AppendToObj(post, - " (invalid octal number?)", -1); + " (invalid octal number?)", + TCL_AUTO_LENGTH); parsePtr->errorType = TCL_PARSE_BAD_NUMBER; errCode = "BADNUMBER"; subErrCode = "OCTAL"; @@ -800,7 +804,8 @@ ParseExpr( default: if (isdigit(UCHAR(start[1]))) { Tcl_AppendToObj(post, - " (invalid octal number?)", -1); + " (invalid octal number?)", + TCL_AUTO_LENGTH); parsePtr->errorType = TCL_PARSE_BAD_NUMBER; errCode = "BADNUMBER"; subErrCode = "OCTAL"; @@ -842,7 +847,7 @@ ParseExpr( Tcl_Token *tokenPtr; const char *end = start; - int wordIndex; + Tcl_Size wordIndex; int code = TCL_OK; /* @@ -1449,7 +1454,7 @@ ParseExpr( */ if (post != NULL) { - Tcl_AppendToObj(msg, ";\n", -1); + Tcl_AppendToObj(msg, ";\n", TCL_AUTO_LENGTH); Tcl_AppendObjToObj(msg, post); Tcl_DecrRefCount(post); } @@ -1504,13 +1509,13 @@ ConvertTreeToTokens( Tcl_Token *tokenPtr, Tcl_Parse *parsePtr) { - int subExprTokenIdx = 0; + Tcl_Size subExprTokenIdx = 0; OpNode *nodePtr = nodes; int next = nodePtr->right; while (1) { Tcl_Token *subExprTokenPtr; - int scanned, parentIdx; + Tcl_Size scanned, parentIdx; unsigned char lexeme; /* @@ -1577,7 +1582,7 @@ ConvertTreeToTokens( * do better. */ - int toCopy = tokenPtr->numComponents + 1; + Tcl_Size toCopy = tokenPtr->numComponents + 1; if (tokenPtr->numComponents == tokenPtr[1].numComponents + 1) { /* @@ -1793,7 +1798,7 @@ ConvertTreeToTokens( */ subExprTokenPtr->numComponents = - ((int)parsePtr->numTokens - subExprTokenIdx) - 1; + (parsePtr->numTokens - subExprTokenIdx) - 1; /* * Finally, as we return up the tree to our parent, pop the @@ -1856,10 +1861,10 @@ Tcl_ParseExpr( { int code; OpNode *opTree = NULL; /* Will point to the tree of operators. */ - Tcl_Obj *litList; /* List to hold the literals. */ - Tcl_Obj *funcList; /* List to hold the functon names. */ - Tcl_Parse *exprParsePtr = (Tcl_Parse *)TclStackAlloc(interp, sizeof(Tcl_Parse)); - /* Holds the Tcl_Tokens of substitutions. */ + Tcl_Obj *litList; /* List to hold the literals. */ + Tcl_Obj *funcList; /* List to hold the functon names. */ + Tcl_Parse *exprParsePtr = (Tcl_Parse *)TclStackAlloc(interp, + sizeof(Tcl_Parse)); /* Holds the Tcl_Tokens of substitutions. */ TclNewObj(litList); TclNewObj(funcList); @@ -2082,7 +2087,10 @@ ParseLexeme( number: *lexemePtr = NUMBER; if (literalPtr) { - TclInitStringRep(literal, start, end-start); + if(!TclAttemptInitStringRep(literal, start, end-start)) { + Tcl_DecrRefCount(literal); + literal = NULL; + } *literalPtr = literal; } else { Tcl_DecrRefCount(literal); @@ -2268,7 +2276,7 @@ ExecConstantExprTree( TclInitCompileEnv(interp, envPtr, NULL, 0, NULL, 0); CompileExprTree(interp, nodes, index, litObjvPtr, NULL, NULL, envPtr, 0 /* optimize */); - TclEmitOpcode(INST_DONE, envPtr); + OP( DONE); byteCodePtr = TclInitByteCode(envPtr); TclFreeCompileEnv(envPtr); TclStackFree(interp, envPtr); @@ -2333,19 +2341,12 @@ CompileExprTree( switch (nodePtr->lexeme) { case FUNCTION: { - Tcl_DString cmdName; - const char *p; - Tcl_Size length; + Tcl_Obj *cmdName; - Tcl_DStringInit(&cmdName); - TclDStringAppendLiteral(&cmdName, "tcl::mathfunc::"); - p = TclGetStringFromObj(*funcObjv, &length); + TclNewLiteralStringObj(cmdName, "tcl::mathfunc::"); + Tcl_AppendObjToObj(cmdName, *funcObjv); funcObjv++; - Tcl_DStringAppend(&cmdName, p, length); - TclEmitPush(TclRegisterLiteral(envPtr, - Tcl_DStringValue(&cmdName), - Tcl_DStringLength(&cmdName), LITERAL_CMD_NAME), envPtr); - Tcl_DStringFree(&cmdName); + PUSH_OBJ_FLAGS(cmdName, LITERAL_CMD_NAME); /* * Start a count of the number of words in this function @@ -2370,7 +2371,7 @@ CompileExprTree( jumpPtr = newJump; TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpPtr->jump); - TclAdjustStackDepth(-1, envPtr); + STKDELTA(-1); if (convert) { jumpPtr->jump.jumpType = TCL_TRUE_JUMP; } @@ -2386,13 +2387,14 @@ CompileExprTree( break; } } else { - int pc1, pc2, target; + Tcl_Size target; + Tcl_BytecodeLabel pc1, pc2; switch (nodePtr->lexeme) { case START: case QUESTION: if (convert && (nodePtr == rootPtr)) { - TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr); + OP( TRY_CVT_TO_NUMERIC); } break; case OPEN_PAREN: @@ -2405,11 +2407,7 @@ CompileExprTree( * command with the correct number of arguments. */ - if (numWords < 255) { - TclEmitInvoke(envPtr, INST_INVOKE_STK1, numWords); - } else { - TclEmitInvoke(envPtr, INST_INVOKE_STK4, numWords); - } + INVOKE4( INVOKE_STK, numWords); /* * Restore any saved numWords value. @@ -2431,15 +2429,13 @@ CompileExprTree( jumpPtr->jump.jumpType = TCL_UNCONDITIONAL_JUMP; convert = 1; } - target = jumpPtr->jump.codeOffset + 2; - if (TclFixupForwardJumpToHere(envPtr, &jumpPtr->jump, 127)) { - target += 3; - } + target = jumpPtr->jump.codeOffset + 5; + TclFixupForwardJumpToHere(envPtr, &jumpPtr->jump); freePtr = jumpPtr; jumpPtr = jumpPtr->next; TclStackFree(interp, freePtr); TclFixupForwardJump(envPtr, &jumpPtr->jump, - target - jumpPtr->jump.codeOffset, 127); + target - jumpPtr->jump.codeOffset); freePtr = jumpPtr; jumpPtr = jumpPtr->next; @@ -2448,23 +2444,18 @@ CompileExprTree( case AND: case OR: CLANG_ASSERT(jumpPtr); - pc1 = CurrentOffset(envPtr); - TclEmitInstInt1((nodePtr->lexeme == AND) ? INST_JUMP_FALSE1 - : INST_JUMP_TRUE1, 0, envPtr); - TclEmitPush(TclRegisterLiteral(envPtr, - (nodePtr->lexeme == AND) ? "1" : "0", 1, 0), envPtr); - pc2 = CurrentOffset(envPtr); - TclEmitInstInt1(INST_JUMP1, 0, envPtr); - TclAdjustStackDepth(-1, envPtr); - TclStoreInt1AtPtr(CurrentOffset(envPtr) - pc1, - envPtr->codeStart + pc1 + 1); - if (TclFixupForwardJumpToHere(envPtr, &jumpPtr->jump, 127)) { - pc2 += 3; + if (nodePtr->lexeme == AND) { + FWDJUMP( JUMP_FALSE, pc1); + } else { + FWDJUMP( JUMP_TRUE, pc1); } - TclEmitPush(TclRegisterLiteral(envPtr, - (nodePtr->lexeme == AND) ? "0" : "1", 1, 0), envPtr); - TclStoreInt1AtPtr(CurrentOffset(envPtr) - pc2, - envPtr->codeStart + pc2 + 1); + PUSH_STRING( (nodePtr->lexeme == AND) ? "1" : "0"); + FWDJUMP( JUMP, pc2); + STKDELTA(-1); + FWDLABEL(pc1); + TclFixupForwardJumpToHere(envPtr, &jumpPtr->jump); + PUSH_STRING( (nodePtr->lexeme == AND) ? "0" : "1"); + FWDLABEL(pc2); convert = 0; freePtr = jumpPtr; jumpPtr = jumpPtr->next; @@ -2494,9 +2485,7 @@ CompileExprTree( Tcl_Obj *literal = *litObjv; if (optimize) { - Tcl_Size length; - const char *bytes = TclGetStringFromObj(literal, &length); - int idx = TclRegisterLiteral(envPtr, bytes, length, 0); + int idx = PUSH_OBJ_FLAGS(literal, 0); Tcl_Obj *objPtr = TclFetchLiteral(envPtr, idx); if ((objPtr->typePtr == NULL) && (literal->typePtr != NULL)) { @@ -2517,7 +2506,6 @@ CompileExprTree( objPtr->internalRep = literal->internalRep; literal->typePtr = NULL; } - TclEmitPush(idx, envPtr); } else { /* * When optimize==0, we know the expression is a one-off and @@ -2528,7 +2516,7 @@ CompileExprTree( * that preserves internalreps. */ - TclEmitPush(TclAddLiteralObj(envPtr, literal, NULL), envPtr); + PUSH_OBJ( literal); } (*litObjvPtr)++; break; @@ -2672,7 +2660,8 @@ TclSortingOpCmd( TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)clientData; Tcl_Obj **litObjv = (Tcl_Obj **)TclStackAlloc(interp, 2 * (objc-2) * sizeof(Tcl_Obj *)); - OpNode *nodes = (OpNode *)TclStackAlloc(interp, 2 * (objc-2) * sizeof(OpNode)); + OpNode *nodes = (OpNode *)TclStackAlloc(interp, + 2 * (objc-2) * sizeof(OpNode)); unsigned char lexeme; int i, lastAnd = 1; Tcl_Obj *const *litObjPtrPtr = litObjv; @@ -2683,29 +2672,30 @@ TclSortingOpCmd( nodes[0].lexeme = START; nodes[0].mark = MARK_RIGHT; for (i=2; i<objc-1; i++) { - litObjv[2*(i-1)-1] = objv[i]; - nodes[2*(i-1)-1].lexeme = lexeme; - nodes[2*(i-1)-1].mark = MARK_LEFT; - nodes[2*(i-1)-1].left = OT_LITERAL; - nodes[2*(i-1)-1].right = OT_LITERAL; - - litObjv[2*(i-1)] = objv[i]; - nodes[2*(i-1)].lexeme = AND; - nodes[2*(i-1)].mark = MARK_LEFT; - nodes[2*(i-1)].left = lastAnd; - nodes[lastAnd].p.parent = 2*(i-1); - - nodes[2*(i-1)].right = 2*(i-1)+1; - nodes[2*(i-1)+1].p.parent= 2*(i-1); - - lastAnd = 2*(i-1); + int j = 2 * (i - 1); + litObjv[j - 1] = objv[i]; + nodes[j - 1].lexeme = lexeme; + nodes[j - 1].mark = MARK_LEFT; + nodes[j - 1].left = OT_LITERAL; + nodes[j - 1].right = OT_LITERAL; + + litObjv[j] = objv[i]; + nodes[j].lexeme = AND; + nodes[j].mark = MARK_LEFT; + nodes[j].left = lastAnd; + nodes[lastAnd].p.parent = j; + + nodes[j].right = j + 1; + nodes[j + 1].p.parent= j; + + lastAnd = j; } - litObjv[2*(objc-2)-1] = objv[objc-1]; + litObjv[2 * (objc - 2) - 1] = objv[objc - 1]; - nodes[2*(objc-2)-1].lexeme = lexeme; - nodes[2*(objc-2)-1].mark = MARK_LEFT; - nodes[2*(objc-2)-1].left = OT_LITERAL; - nodes[2*(objc-2)-1].right = OT_LITERAL; + nodes[2 * (objc - 2) - 1].lexeme = lexeme; + nodes[2 * (objc - 2) - 1].mark = MARK_LEFT; + nodes[2 * (objc - 2) - 1].left = OT_LITERAL; + nodes[2 * (objc - 2) - 1].right = OT_LITERAL; nodes[0].right = lastAnd; nodes[lastAnd].p.parent = 0; @@ -2799,7 +2789,8 @@ TclVariadicOpCmd( return code; } else { Tcl_Obj *const *litObjv = objv + 1; - OpNode *nodes = (OpNode *)TclStackAlloc(interp, (objc-1) * sizeof(OpNode)); + OpNode *nodes = (OpNode *)TclStackAlloc(interp, + (objc - 1) * sizeof(OpNode)); int i, lastOp = OT_LITERAL; nodes[0].lexeme = START; diff --git a/generic/tclCompile.c b/generic/tclCompile.c index beb716c..ece41c8 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -13,6 +13,7 @@ */ #include "tclInt.h" +#define ALLOW_DEPRECATED_OPCODES #include "tclCompile.h" #include <assert.h> @@ -26,11 +27,31 @@ */ #ifdef TCL_COMPILE_DEBUG -int tclTraceCompile = 0; +int tclTraceCompile = TCL_TRACE_BYTECODE_COMPILE_NONE; static int traceInitialized = 0; #endif /* + * Minor helpers for the table below. The compiler doesn't enforce + * the deprecation here; that's not possible. + */ + +#define TCL_INSTRUCTION_ENTRY(name,stack) \ + {name,1,stack,0,{OPERAND_NONE,OPERAND_NONE}} +#define TCL_INSTRUCTION_ENTRY1(name,size,stack,type1) \ + {name,size,stack,1,{type1,OPERAND_NONE}} +#define TCL_INSTRUCTION_ENTRY2(name,size,stack,type1,type2) \ + {name,size,stack,2,{type1,type2}} + +/* TODO: Mark these differently when REMOVE_DEPRECATED_OPCODES is defined. */ +#define DEPRECATED_INSTRUCTION_ENTRY(name,stack) \ + {name,1,stack,0,{OPERAND_NONE,OPERAND_NONE}} +#define DEPRECATED_INSTRUCTION_ENTRY1(name,size,stack,type1) \ + {name,size,stack,1,{type1,OPERAND_NONE}} +#define DEPRECATED_INSTRUCTION_ENTRY2(name,size,stack,type1,type2) \ + {name,size,stack,2,{type1,type2}} + +/* * A table describing the Tcl bytecode instructions. Entries in this table * must correspond to the instruction opcode definitions in tclCompile.h. The * names "op1" and "op4" refer to an instruction's one or four byte first @@ -43,216 +64,309 @@ static int traceInitialized = 0; */ InstructionDesc const tclInstructionTable[] = { - /* Name Bytes stackEffect #Opnds Operand types */ - {"done", 1, -1, 0, {OPERAND_NONE}}, + /* Name Bytes stackEffect Operand types */ + TCL_INSTRUCTION_ENTRY( + "done", -1), /* Finish ByteCode execution and return stktop (top stack item) */ - {"push1", 2, +1, 1, {OPERAND_LIT1}}, + DEPRECATED_INSTRUCTION_ENTRY1( + "push1", 2, +1, OPERAND_LIT1), /* Push object at ByteCode objArray[op1] */ - {"push4", 5, +1, 1, {OPERAND_LIT4}}, + TCL_INSTRUCTION_ENTRY1( + "push", 5, +1, OPERAND_LIT4), /* Push object at ByteCode objArray[op4] */ - {"pop", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "pop", -1), /* Pop the topmost stack object */ - {"dup", 1, +1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "dup", +1), /* Duplicate the topmost stack object and push the result */ - {"strcat", 2, INT_MIN, 1, {OPERAND_UINT1}}, + TCL_INSTRUCTION_ENTRY1( + "strcat", 2, INT_MIN, OPERAND_UINT1), /* Concatenate the top op1 items and push result */ - {"invokeStk1", 2, INT_MIN, 1, {OPERAND_UINT1}}, + DEPRECATED_INSTRUCTION_ENTRY1( + "invokeStk1", 2, INT_MIN, OPERAND_UINT1), /* Invoke command named objv[0]; <objc,objv> = <op1,top op1> */ - {"invokeStk4", 5, INT_MIN, 1, {OPERAND_UINT4}}, + TCL_INSTRUCTION_ENTRY1( + "invokeStk", 5, INT_MIN, OPERAND_UINT4), /* Invoke command named objv[0]; <objc,objv> = <op4,top op4> */ - {"evalStk", 1, 0, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "evalStk", 0), /* Evaluate command in stktop using Tcl_EvalObj. */ - {"exprStk", 1, 0, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "exprStk", 0), /* Execute expression in stktop using Tcl_ExprStringObj. */ - {"loadScalar1", 2, 1, 1, {OPERAND_LVT1}}, + DEPRECATED_INSTRUCTION_ENTRY1( + "loadScalar1", 2, 1, OPERAND_LVT1), /* Load scalar variable at index op1 <= 255 in call frame */ - {"loadScalar4", 5, 1, 1, {OPERAND_LVT4}}, + TCL_INSTRUCTION_ENTRY1( + "loadScalar", 5, 1, OPERAND_LVT4), /* Load scalar variable at index op1 >= 256 in call frame */ - {"loadScalarStk", 1, 0, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "loadScalarStk", 0), /* Load scalar variable; scalar's name is stktop */ - {"loadArray1", 2, 0, 1, {OPERAND_LVT1}}, + DEPRECATED_INSTRUCTION_ENTRY1( + "loadArray1", 2, 0, OPERAND_LVT1), /* Load array element; array at slot op1<=255, element is stktop */ - {"loadArray4", 5, 0, 1, {OPERAND_LVT4}}, + TCL_INSTRUCTION_ENTRY1( + "loadArray", 5, 0, OPERAND_LVT4), /* Load array element; array at slot op1 > 255, element is stktop */ - {"loadArrayStk", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "loadArrayStk", -1), /* Load array element; element is stktop, array name is stknext */ - {"loadStk", 1, 0, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "loadStk", 0), /* Load general variable; unparsed variable name is stktop */ - {"storeScalar1", 2, 0, 1, {OPERAND_LVT1}}, + DEPRECATED_INSTRUCTION_ENTRY1( + "storeScalar1", 2, 0, OPERAND_LVT1), /* Store scalar variable at op1<=255 in frame; value is stktop */ - {"storeScalar4", 5, 0, 1, {OPERAND_LVT4}}, + TCL_INSTRUCTION_ENTRY1( + "storeScalar", 5, 0, OPERAND_LVT4), /* Store scalar variable at op1 > 255 in frame; value is stktop */ - {"storeScalarStk", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "storeScalarStk", -1), /* Store scalar; value is stktop, scalar name is stknext */ - {"storeArray1", 2, -1, 1, {OPERAND_LVT1}}, + DEPRECATED_INSTRUCTION_ENTRY1( + "storeArray1", 2, -1, OPERAND_LVT1), /* Store array element; array at op1<=255, value is top then elem */ - {"storeArray4", 5, -1, 1, {OPERAND_LVT4}}, + TCL_INSTRUCTION_ENTRY1( + "storeArray", 5, -1, OPERAND_LVT4), /* Store array element; array at op1>=256, value is top then elem */ - {"storeArrayStk", 1, -2, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "storeArrayStk", -2), /* Store array element; value is stktop, then elem, array names */ - {"storeStk", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "storeStk", -1), /* Store general variable; value is stktop, then unparsed name */ - {"incrScalar1", 2, 0, 1, {OPERAND_LVT1}}, + DEPRECATED_INSTRUCTION_ENTRY1( + "incrScalar1", 2, 0, OPERAND_LVT1), /* Incr scalar at index op1<=255 in frame; incr amount is stktop */ - {"incrScalarStk", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "incrScalarStk", -1), /* Incr scalar; incr amount is stktop, scalar's name is stknext */ - {"incrArray1", 2, -1, 1, {OPERAND_LVT1}}, + DEPRECATED_INSTRUCTION_ENTRY1( + "incrArray1", 2, -1, OPERAND_LVT1), /* Incr array elem; arr at slot op1<=255, amount is top then elem */ - {"incrArrayStk", 1, -2, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "incrArrayStk", -2), /* Incr array element; amount is top then elem then array names */ - {"incrStk", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "incrStk", -1), /* Incr general variable; amount is stktop then unparsed var name */ - {"incrScalar1Imm", 3, +1, 2, {OPERAND_LVT1, OPERAND_INT1}}, + DEPRECATED_INSTRUCTION_ENTRY2( + "incrScalar1Imm", 3, +1, OPERAND_LVT1, OPERAND_INT1), /* Incr scalar at slot op1 <= 255; amount is 2nd operand byte */ - {"incrScalarStkImm", 2, 0, 1, {OPERAND_INT1}}, + TCL_INSTRUCTION_ENTRY1( + "incrScalarStkImm",2, 0, OPERAND_INT1), /* Incr scalar; scalar name is stktop; incr amount is op1 */ - {"incrArray1Imm", 3, 0, 2, {OPERAND_LVT1, OPERAND_INT1}}, + DEPRECATED_INSTRUCTION_ENTRY2( + "incrArray1Imm", 3, 0, OPERAND_LVT1, OPERAND_INT1), /* Incr array elem; array at slot op1 <= 255, elem is stktop, * amount is 2nd operand byte */ - {"incrArrayStkImm", 2, -1, 1, {OPERAND_INT1}}, + TCL_INSTRUCTION_ENTRY1( + "incrArrayStkImm",2, -1, OPERAND_INT1), /* Incr array element; elem is top then array name, amount is op1 */ - {"incrStkImm", 2, 0, 1, {OPERAND_INT1}}, + TCL_INSTRUCTION_ENTRY1( + "incrStkImm", 2, 0, OPERAND_INT1), /* Incr general variable; unparsed name is top, amount is op1 */ - {"jump1", 2, 0, 1, {OPERAND_OFFSET1}}, + DEPRECATED_INSTRUCTION_ENTRY1( + "jump1", 2, 0, OPERAND_OFFSET1), /* Jump relative to (pc + op1) */ - {"jump4", 5, 0, 1, {OPERAND_OFFSET4}}, + TCL_INSTRUCTION_ENTRY1( + "jump", 5, 0, OPERAND_OFFSET4), /* Jump relative to (pc + op4) */ - {"jumpTrue1", 2, -1, 1, {OPERAND_OFFSET1}}, + DEPRECATED_INSTRUCTION_ENTRY1( + "jumpTrue1", 2, -1, OPERAND_OFFSET1), /* Jump relative to (pc + op1) if stktop expr object is true */ - {"jumpTrue4", 5, -1, 1, {OPERAND_OFFSET4}}, + TCL_INSTRUCTION_ENTRY1( + "jumpTrue", 5, -1, OPERAND_OFFSET4), /* Jump relative to (pc + op4) if stktop expr object is true */ - {"jumpFalse1", 2, -1, 1, {OPERAND_OFFSET1}}, + DEPRECATED_INSTRUCTION_ENTRY1( + "jumpFalse1", 2, -1, OPERAND_OFFSET1), /* Jump relative to (pc + op1) if stktop expr object is false */ - {"jumpFalse4", 5, -1, 1, {OPERAND_OFFSET4}}, + TCL_INSTRUCTION_ENTRY1( + "jumpFalse", 5, -1, OPERAND_OFFSET4), /* Jump relative to (pc + op4) if stktop expr object is false */ - {"bitor", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "bitor", -1), /* Bitwise or: push (stknext | stktop) */ - {"bitxor", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "bitxor", -1), /* Bitwise xor push (stknext ^ stktop) */ - {"bitand", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "bitand", -1), /* Bitwise and: push (stknext & stktop) */ - {"eq", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "eq", -1), /* Equal: push (stknext == stktop) */ - {"neq", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "neq", -1), /* Not equal: push (stknext != stktop) */ - {"lt", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "lt", -1), /* Less: push (stknext < stktop) */ - {"gt", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "gt", -1), /* Greater: push (stknext > stktop) */ - {"le", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "le", -1), /* Less or equal: push (stknext <= stktop) */ - {"ge", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "ge", -1), /* Greater or equal: push (stknext >= stktop) */ - {"lshift", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "lshift", -1), /* Left shift: push (stknext << stktop) */ - {"rshift", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "rshift", -1), /* Right shift: push (stknext >> stktop) */ - {"add", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "add", -1), /* Add: push (stknext + stktop) */ - {"sub", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "sub", -1), /* Sub: push (stkext - stktop) */ - {"mult", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "mult", -1), /* Multiply: push (stknext * stktop) */ - {"div", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "div", -1), /* Divide: push (stknext / stktop) */ - {"mod", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "mod", -1), /* Mod: push (stknext % stktop) */ - {"uplus", 1, 0, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "uplus", 0), /* Unary plus: push +stktop */ - {"uminus", 1, 0, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "uminus", 0), /* Unary minus: push -stktop */ - {"bitnot", 1, 0, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "bitnot", 0), /* Bitwise not: push ~stktop */ - {"not", 1, 0, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "not", 0), /* Logical not: push !stktop */ - {"tryCvtToNumeric", 1, 0, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "tryCvtToNumeric", 0), /* Try converting stktop to first int then double if possible. */ - {"break", 1, 0, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "break", 0), /* Abort closest enclosing loop; if none, return TCL_BREAK code. */ - {"continue", 1, 0, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "continue", 0), /* Skip to next iteration of closest enclosing loop; if none, return * TCL_CONTINUE code. */ - {"beginCatch4", 5, 0, 1, {OPERAND_UINT4}}, + TCL_INSTRUCTION_ENTRY1( + "beginCatch", 5, 0, OPERAND_UINT4), /* Record start of catch with the operand's exception index. Push the * current stack depth onto a special catch stack. */ - {"endCatch", 1, 0, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "endCatch", 0), /* End of last catch. Pop the bytecode interpreter's catch stack. */ - {"pushResult", 1, +1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "pushResult", +1), /* Push the interpreter's object result onto the stack. */ - {"pushReturnCode", 1, +1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "pushReturnCode", +1), /* Push interpreter's return code (e.g. TCL_OK or TCL_ERROR) as a new * object onto the stack. */ - {"streq", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "streq", -1), /* Str Equal: push (stknext eq stktop) */ - {"strneq", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "strneq", -1), /* Str !Equal: push (stknext neq stktop) */ - {"strcmp", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "strcmp", -1), /* Str Compare: push (stknext cmp stktop) */ - {"strlen", 1, 0, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "strlen", 0), /* Str Length: push (strlen stktop) */ - {"strindex", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "strindex", -1), /* Str Index: push (strindex stknext stktop) */ - {"strmatch", 2, -1, 1, {OPERAND_INT1}}, + TCL_INSTRUCTION_ENTRY1( + "strmatch", 2, -1, OPERAND_INT1), /* Str Match: push (strmatch stknext stktop) opnd == nocase */ - {"list", 5, INT_MIN, 1, {OPERAND_UINT4}}, + TCL_INSTRUCTION_ENTRY1( + "list", 5, INT_MIN, OPERAND_UINT4), /* List: push (stk1 stk2 ... stktop) */ - {"listIndex", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "listIndex", -1), /* List Index: push (listindex stknext stktop) */ - {"listLength", 1, 0, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "listLength", 0), /* List Len: push (listlength stktop) */ - {"appendScalar1", 2, 0, 1, {OPERAND_LVT1}}, + DEPRECATED_INSTRUCTION_ENTRY1( + "appendScalar1", 2, 0, OPERAND_LVT1), /* Append scalar variable at op1<=255 in frame; value is stktop */ - {"appendScalar4", 5, 0, 1, {OPERAND_LVT4}}, + TCL_INSTRUCTION_ENTRY1( + "appendScalar", 5, 0, OPERAND_LVT4), /* Append scalar variable at op1 > 255 in frame; value is stktop */ - {"appendArray1", 2, -1, 1, {OPERAND_LVT1}}, + DEPRECATED_INSTRUCTION_ENTRY1( + "appendArray1", 2, -1, OPERAND_LVT1), /* Append array element; array at op1<=255, value is top then elem */ - {"appendArray4", 5, -1, 1, {OPERAND_LVT4}}, + TCL_INSTRUCTION_ENTRY1( + "appendArray", 5, -1, OPERAND_LVT4), /* Append array element; array at op1>=256, value is top then elem */ - {"appendArrayStk", 1, -2, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "appendArrayStk", -2), /* Append array element; value is stktop, then elem, array names */ - {"appendStk", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "appendStk", -1), /* Append general variable; value is stktop, then unparsed name */ - {"lappendScalar1", 2, 0, 1, {OPERAND_LVT1}}, + DEPRECATED_INSTRUCTION_ENTRY1( + "lappendScalar1", 2, 0, OPERAND_LVT1), /* Lappend scalar variable at op1<=255 in frame; value is stktop */ - {"lappendScalar4", 5, 0, 1, {OPERAND_LVT4}}, + TCL_INSTRUCTION_ENTRY1( + "lappendScalar", 5, 0, OPERAND_LVT4), /* Lappend scalar variable at op1 > 255 in frame; value is stktop */ - {"lappendArray1", 2, -1, 1, {OPERAND_LVT1}}, + DEPRECATED_INSTRUCTION_ENTRY1( + "lappendArray1", 2, -1, OPERAND_LVT1), /* Lappend array element; array at op1<=255, value is top then elem */ - {"lappendArray4", 5, -1, 1, {OPERAND_LVT4}}, + TCL_INSTRUCTION_ENTRY1( + "lappendArray", 5, -1, OPERAND_LVT4), /* Lappend array element; array at op1>=256, value is top then elem */ - {"lappendArrayStk", 1, -2, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "lappendArrayStk", -2), /* Lappend array element; value is stktop, then elem, array names */ - {"lappendStk", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "lappendStk", -1), /* Lappend general variable; value is stktop, then unparsed name */ - {"lindexMulti", 5, INT_MIN, 1, {OPERAND_UINT4}}, + TCL_INSTRUCTION_ENTRY1( + "lindexMulti", 5, INT_MIN, OPERAND_UINT4), /* Lindex with generalized args, operand is number of stacked objs * used: (operand-1) entries from stktop are the indices; then list to * process. */ - {"over", 5, +1, 1, {OPERAND_UINT4}}, + TCL_INSTRUCTION_ENTRY1( + "over", 5, +1, OPERAND_UINT4), /* Duplicate the arg-th element from top of stack (TOS=0) */ - {"lsetList", 1, -2, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "lsetList", -2), /* Four-arg version of 'lset'. stktop is old value; next is new * element value, next is the index list; pushes new value */ - {"lsetFlat", 5, INT_MIN, 1, {OPERAND_UINT4}}, + TCL_INSTRUCTION_ENTRY1( + "lsetFlat", 5, INT_MIN, OPERAND_UINT4), /* Three- or >=5-arg version of 'lset', operand is number of stacked * objs: stktop is old value, next is new element value, next come - * (operand-2) indices; pushes the new value. - */ + * (operand-2) indices; pushes the new value. */ - {"returnImm", 9, -1, 2, {OPERAND_INT4, OPERAND_UINT4}}, + TCL_INSTRUCTION_ENTRY2( + "returnImm", 9, -1, OPERAND_INT4, OPERAND_UINT4), /* Compiled [return], code, level are operands; options and result * are on the stack. */ - {"expon", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "expon", -1), /* Binary exponentiation operator: push (stknext ** stktop) */ /* @@ -263,264 +377,330 @@ InstructionDesc const tclInstructionTable[] = { * See the comments further down in this file, where INST_INVOKE_EXPANDED * is emitted. */ - {"expandStart", 1, 0, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "expandStart", 0), /* Start of command with {*} (expanded) arguments */ - {"expandStkTop", 5, 0, 1, {OPERAND_UINT4}}, + TCL_INSTRUCTION_ENTRY1( + "expandStkTop", 5, 0, OPERAND_UINT4), /* Expand the list at stacktop: push its elements on the stack */ - {"invokeExpanded", 1, 0, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "invokeExpanded", 0), /* Invoke the command marked by the last 'expandStart' */ - {"listIndexImm", 5, 0, 1, {OPERAND_IDX4}}, + TCL_INSTRUCTION_ENTRY1( + "listIndexImm", 5, 0, OPERAND_IDX4), /* List Index: push (lindex stktop op4) */ - {"listRangeImm", 9, 0, 2, {OPERAND_IDX4, OPERAND_IDX4}}, + TCL_INSTRUCTION_ENTRY2( + "listRangeImm", 9, 0, OPERAND_IDX4, OPERAND_IDX4), /* List Range: push (lrange stktop op4 op4) */ - {"startCommand", 9, 0, 2, {OPERAND_OFFSET4, OPERAND_UINT4}}, + TCL_INSTRUCTION_ENTRY2( + "startCommand", 9, 0, OPERAND_OFFSET4, OPERAND_UINT4), /* Start of bytecoded command: op is the length of the cmd's code, op2 * is number of commands here */ - {"listIn", 1, -1, 0, {OPERAND_NONE}}, - /* List containment: push [lsearch stktop stknext]>=0) */ - {"listNotIn", 1, -1, 0, {OPERAND_NONE}}, - /* List negated containment: push [lsearch stktop stknext]<0) */ + TCL_INSTRUCTION_ENTRY( + "listIn", -1), + /* List containment: push [lsearch stktop stknext]>=0 */ + TCL_INSTRUCTION_ENTRY( + "listNotIn", -1), + /* List negated containment: push [lsearch stktop stknext]<0 */ - {"pushReturnOpts", 1, +1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "pushReturnOpts", +1), /* Push the interpreter's return option dictionary as an object on the * stack. */ - {"returnStk", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "returnStk", -1), /* Compiled [return]; options and result are on the stack, code and * level are in the options. */ - {"dictGet", 5, INT_MIN, 1, {OPERAND_UINT4}}, + TCL_INSTRUCTION_ENTRY1( + "dictGet", 5, INT_MIN, OPERAND_UINT4), /* The top op4 words (min 1) are a key path into the dictionary just * below the keys on the stack, and all those values are replaced by * the value read out of that key-path (like [dict get]). * Stack: ... dict key1 ... keyN => ... value */ - {"dictSet", 9, INT_MIN, 2, {OPERAND_UINT4, OPERAND_LVT4}}, + TCL_INSTRUCTION_ENTRY2( + "dictSet", 9, INT_MIN, OPERAND_UINT4, OPERAND_LVT4), /* Update a dictionary value such that the keys are a path pointing to * the value. op4#1 = numKeys, op4#2 = LVTindex * Stack: ... key1 ... keyN value => ... newDict */ - {"dictUnset", 9, INT_MIN, 2, {OPERAND_UINT4, OPERAND_LVT4}}, + TCL_INSTRUCTION_ENTRY2( + "dictUnset", 9, INT_MIN, OPERAND_UINT4, OPERAND_LVT4), /* Update a dictionary value such that the keys are not a path pointing * to any value. op4#1 = numKeys, op4#2 = LVTindex * Stack: ... key1 ... keyN => ... newDict */ - {"dictIncrImm", 9, 0, 2, {OPERAND_INT4, OPERAND_LVT4}}, + TCL_INSTRUCTION_ENTRY2( + "dictIncrImm", 9, 0, OPERAND_INT4, OPERAND_LVT4), /* Update a dictionary value such that the value pointed to by key is * incremented by some value (or set to it if the key isn't in the * dictionary at all). op4#1 = incrAmount, op4#2 = LVTindex * Stack: ... key => ... newDict */ - {"dictAppend", 5, -1, 1, {OPERAND_LVT4}}, + TCL_INSTRUCTION_ENTRY1( + "dictAppend", 5, -1, OPERAND_LVT4), /* Update a dictionary value such that the value pointed to by key has * some value string-concatenated onto it. op4 = LVTindex * Stack: ... key valueToAppend => ... newDict */ - {"dictLappend", 5, -1, 1, {OPERAND_LVT4}}, + TCL_INSTRUCTION_ENTRY1( + "dictLappend", 5, -1, OPERAND_LVT4), /* Update a dictionary value such that the value pointed to by key has * some value list-appended onto it. op4 = LVTindex * Stack: ... key valueToAppend => ... newDict */ - {"dictFirst", 5, +2, 1, {OPERAND_LVT4}}, + TCL_INSTRUCTION_ENTRY1( + "dictFirst", 5, +2, OPERAND_LVT4), /* Begin iterating over the dictionary, using the local scalar * indicated by op4 to hold the iterator state. The local scalar * should not refer to a named variable as the value is not wholly * managed correctly. * Stack: ... dict => ... value key doneBool */ - {"dictNext", 5, +3, 1, {OPERAND_LVT4}}, + TCL_INSTRUCTION_ENTRY1( + "dictNext", 5, +3, OPERAND_LVT4), /* Get the next iteration from the iterator in op4's local scalar. * Stack: ... => ... value key doneBool */ - {"dictUpdateStart", 9, 0, 2, {OPERAND_LVT4, OPERAND_AUX4}}, + TCL_INSTRUCTION_ENTRY2( + "dictUpdateStart", 9, 0, OPERAND_LVT4, OPERAND_AUX4), /* Create the variables (described in the aux data referred to by the * second immediate argument) to mirror the state of the dictionary in * the variable referred to by the first immediate argument. The list * of keys (top of the stack, not popped) must be the same length as * the list of variables. * Stack: ... keyList => ... keyList */ - {"dictUpdateEnd", 9, -1, 2, {OPERAND_LVT4, OPERAND_AUX4}}, + TCL_INSTRUCTION_ENTRY2( + "dictUpdateEnd", 9, -1, OPERAND_LVT4, OPERAND_AUX4), /* Reflect the state of local variables (described in the aux data * referred to by the second immediate argument) back to the state of * the dictionary in the variable referred to by the first immediate * argument. The list of keys (popped from the stack) must be the same * length as the list of variables. * Stack: ... keyList => ... */ - {"jumpTable", 5, -1, 1, {OPERAND_AUX4}}, + TCL_INSTRUCTION_ENTRY1( + "jumpTable", 5, -1, OPERAND_AUX4), /* Jump according to the jump-table (in AuxData as indicated by the * operand) and the argument popped from the list. Always executes the * next instruction if no match against the table's entries was found. + * Keys are strings. * Stack: ... value => ... * Note that the jump table contains offsets relative to the PC when * it points to this instruction; the code is relocatable. */ - {"upvar", 5, -1, 1, {OPERAND_LVT4}}, + TCL_INSTRUCTION_ENTRY1( + "upvar", 5, -1, OPERAND_LVT4), /* finds level and otherName in stack, links to local variable at * index op1. Leaves the level on stack. */ - {"nsupvar", 5, -1, 1, {OPERAND_LVT4}}, + TCL_INSTRUCTION_ENTRY1( + "nsupvar", 5, -1, OPERAND_LVT4), /* finds namespace and otherName in stack, links to local variable at * index op1. Leaves the namespace on stack. */ - {"variable", 5, -1, 1, {OPERAND_LVT4}}, + TCL_INSTRUCTION_ENTRY1( + "variable", 5, -1, OPERAND_LVT4), /* finds namespace and otherName in stack, links to local variable at * index op1. Leaves the namespace on stack. */ - {"syntax", 9, -1, 2, {OPERAND_INT4, OPERAND_UINT4}}, + TCL_INSTRUCTION_ENTRY2( + "syntax", 9, -1, OPERAND_INT4, OPERAND_UINT4), /* Compiled bytecodes to signal syntax error. Equivalent to returnImm * except for the ERR_ALREADY_LOGGED flag in the interpreter. */ - {"reverse", 5, 0, 1, {OPERAND_UINT4}}, + TCL_INSTRUCTION_ENTRY1( + "reverse", 5, 0, OPERAND_UINT4), /* Reverse the order of the arg elements at the top of stack */ - {"regexp", 2, -1, 1, {OPERAND_INT1}}, + TCL_INSTRUCTION_ENTRY1( + "regexp", 2, -1, OPERAND_INT1), /* Regexp: push (regexp stknext stktop) opnd == nocase */ - {"existScalar", 5, 1, 1, {OPERAND_LVT4}}, + TCL_INSTRUCTION_ENTRY1( + "existScalar", 5, 1, OPERAND_LVT4), /* Test if scalar variable at index op1 in call frame exists */ - {"existArray", 5, 0, 1, {OPERAND_LVT4}}, + TCL_INSTRUCTION_ENTRY1( + "existArray", 5, 0, OPERAND_LVT4), /* Test if array element exists; array at slot op1, element is * stktop */ - {"existArrayStk", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "existArrayStk", -1), /* Test if array element exists; element is stktop, array name is * stknext */ - {"existStk", 1, 0, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "existStk", 0), /* Test if general variable exists; unparsed variable name is stktop*/ - {"nop", 1, 0, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "nop", 0), /* Do nothing */ - {"returnCodeBranch", 1, -1, 0, {OPERAND_NONE}}, + DEPRECATED_INSTRUCTION_ENTRY( + "returnCodeBranch1", -1), /* Jump to next instruction based on the return code on top of stack * ERROR: +1; RETURN: +3; BREAK: +5; CONTINUE: +7; - * Other non-OK: +9 - */ + * Other non-OK: +9 */ - {"unsetScalar", 6, 0, 2, {OPERAND_UINT1, OPERAND_LVT4}}, + TCL_INSTRUCTION_ENTRY2( + "unsetScalar", 6, 0, OPERAND_UNSF1, OPERAND_LVT4), /* Make scalar variable at index op2 in call frame cease to exist; * op1 is 1 for errors on problems, 0 otherwise */ - {"unsetArray", 6, -1, 2, {OPERAND_UINT1, OPERAND_LVT4}}, + TCL_INSTRUCTION_ENTRY2( + "unsetArray", 6, -1, OPERAND_UNSF1, OPERAND_LVT4), /* Make array element cease to exist; array at slot op2, element is * stktop; op1 is 1 for errors on problems, 0 otherwise */ - {"unsetArrayStk", 2, -2, 1, {OPERAND_UINT1}}, + TCL_INSTRUCTION_ENTRY1( + "unsetArrayStk", 2, -2, OPERAND_UNSF1), /* Make array element cease to exist; element is stktop, array name is * stknext; op1 is 1 for errors on problems, 0 otherwise */ - {"unsetStk", 2, -1, 1, {OPERAND_UINT1}}, + TCL_INSTRUCTION_ENTRY1( + "unsetStk", 2, -1, OPERAND_UNSF1), /* Make general variable cease to exist; unparsed variable name is * stktop; op1 is 1 for errors on problems, 0 otherwise */ - {"dictExpand", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "dictExpand", -1), /* Probe into a dict and extract it (or a subdict of it) into * variables with matched names. Produces list of keys bound as * result. Part of [dict with]. * Stack: ... dict path => ... keyList */ - {"dictRecombineStk", 1, -3, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "dictRecombineStk", -3), /* Map variable contents back into a dictionary in a variable. Part of * [dict with]. * Stack: ... dictVarName path keyList => ... */ - {"dictRecombineImm", 5, -2, 1, {OPERAND_LVT4}}, + TCL_INSTRUCTION_ENTRY1( + "dictRecombineImm", 5, -2, OPERAND_LVT4), /* Map variable contents back into a dictionary in the local variable * indicated by the LVT index. Part of [dict with]. * Stack: ... path keyList => ... */ - {"dictExists", 5, INT_MIN, 1, {OPERAND_UINT4}}, + TCL_INSTRUCTION_ENTRY1( + "dictExists", 5, INT_MIN, OPERAND_UINT4), /* The top op4 words (min 1) are a key path into the dictionary just * below the keys on the stack, and all those values are replaced by a * boolean indicating whether it is possible to read out a value from * that key-path (like [dict exists]). * Stack: ... dict key1 ... keyN => ... boolean */ - {"verifyDict", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "verifyDict", -1), /* Verifies that the word on the top of the stack is a dictionary, * popping it if it is and throwing an error if it is not. * Stack: ... value => ... */ - {"strmap", 1, -2, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "strmap", -2), /* Simplified version of [string map] that only applies one change * string, and only case-sensitively. * Stack: ... from to string => ... changedString */ - {"strfind", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "strfind", -1), /* Find the first index of a needle string in a haystack string, * producing the index (integer) or -1 if nothing found. * Stack: ... needle haystack => ... index */ - {"strrfind", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "strrfind", -1), /* Find the last index of a needle string in a haystack string, * producing the index (integer) or -1 if nothing found. * Stack: ... needle haystack => ... index */ - {"strrangeImm", 9, 0, 2, {OPERAND_IDX4, OPERAND_IDX4}}, + TCL_INSTRUCTION_ENTRY2( + "strrangeImm", 9, 0, OPERAND_IDX4, OPERAND_IDX4), /* String Range: push (string range stktop op4 op4) */ - {"strrange", 1, -2, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "strrange", -2), /* String Range with non-constant arguments. * Stack: ... string idxA idxB => ... substring */ - {"yield", 1, 0, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "yield", 0), /* Makes the current coroutine yield the value at the top of the * stack, and places the response back on top of the stack when it * resumes. * Stack: ... valueToYield => ... resumeValue */ - {"coroName", 1, +1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "coroName", +1), /* Push the name of the interpreter's current coroutine as an object * on the stack. */ - {"tailcall", 2, INT_MIN, 1, {OPERAND_UINT1}}, + DEPRECATED_INSTRUCTION_ENTRY1( + "tailcall", 2, INT_MIN, OPERAND_UINT1), /* Do a tailcall with the opnd items on the stack as the thing to * tailcall to; opnd must be greater than 0 for the semantics to work * right. */ - {"currentNamespace", 1, +1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "currentNamespace", +1), /* Push the name of the interpreter's current namespace as an object * on the stack. */ - {"infoLevelNumber", 1, +1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "infoLevelNumber", +1), /* Push the stack depth (i.e., [info level]) of the interpreter as an * object on the stack. */ - {"infoLevelArgs", 1, 0, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "infoLevelArgs", 0), /* Push the argument words to a stack depth (i.e., [info level <n>]) * of the interpreter as an object on the stack. * Stack: ... depth => ... argList */ - {"resolveCmd", 1, 0, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "resolveCmd", 0), /* Resolves the command named on the top of the stack to its fully * qualified version, or produces the empty string if no such command * exists. Never generates errors. * Stack: ... cmdName => ... fullCmdName */ - {"tclooSelf", 1, +1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "tclooSelf", +1), /* Push the identity of the current TclOO object (i.e., the name of * its current public access command) on the stack. */ - {"tclooClass", 1, 0, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "tclooClass", 0), /* Push the class of the TclOO object named at the top of the stack * onto the stack. * Stack: ... object => ... class */ - {"tclooNamespace", 1, 0, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "tclooNamespace", 0), /* Push the namespace of the TclOO object named at the top of the * stack onto the stack. * Stack: ... object => ... namespace */ - {"tclooIsObject", 1, 0, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "tclooIsObject", 0), /* Push whether the value named at the top of the stack is a TclOO * object (i.e., a boolean). Can corrupt the interpreter result * despite not throwing, so not safe for use in a post-exception * context. * Stack: ... value => ... boolean */ - {"arrayExistsStk", 1, 0, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "arrayExistsStk", 0), /* Looks up the element on the top of the stack and tests whether it * is an array. Pushes a boolean describing whether this is the * case. Also runs the whole-array trace on the named variable, so can * throw anything. * Stack: ... varName => ... boolean */ - {"arrayExistsImm", 5, +1, 1, {OPERAND_LVT4}}, + TCL_INSTRUCTION_ENTRY1( + "arrayExistsImm", 5, +1, OPERAND_LVT4), /* Looks up the variable indexed by opnd and tests whether it is an * array. Pushes a boolean describing whether this is the case. Also * runs the whole-array trace on the named variable, so can throw * anything. * Stack: ... => ... boolean */ - {"arrayMakeStk", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "arrayMakeStk", -1), /* Forces the element on the top of the stack to be the name of an * array. * Stack: ... varName => ... */ - {"arrayMakeImm", 5, 0, 1, {OPERAND_LVT4}}, + TCL_INSTRUCTION_ENTRY1( + "arrayMakeImm", 5, 0, OPERAND_LVT4), /* Forces the variable indexed by opnd to be an array. Does not touch * the stack. */ - {"invokeReplace", 6, INT_MIN, 2, {OPERAND_UINT4,OPERAND_UINT1}}, + TCL_INSTRUCTION_ENTRY2( + "invokeReplace", 6, INT_MIN, OPERAND_UINT4, OPERAND_UINT1), /* Invoke command named objv[0], replacing the first two words with - * the word at the top of the stack; + * the op1 words at the top of the stack; * <objc,objv> = <op4,top op4 after popping 1> */ - {"listConcat", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "listConcat", -1), /* Concatenates the two lists at the top of the stack into a single * list and pushes that resulting list onto the stack. * Stack: ... list1 list2 => ... [lconcat list1 list2] */ - {"expandDrop", 1, 0, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "expandDrop", 0), /* Drops an element from the auxiliary stack, popping stack elements * until the matching stack depth is reached. */ /* New foreach implementation */ - {"foreach_start", 5, +2, 1, {OPERAND_AUX4}}, + TCL_INSTRUCTION_ENTRY1( + "foreach_start", 5, +2, OPERAND_AUX4), /* Initialize execution of a foreach loop. Operand is aux data index * of the ForeachInfo structure for the foreach command. It pushes 2 * elements which hold runtime params for foreach_step, they are later @@ -530,73 +710,87 @@ InstructionDesc const tclInstructionTable[] = { * the foreach_step instruction paired with it; the stack info below * is only nominal. * Stack: ... listObjs... => ... listObjs... iterTracker info */ - {"foreach_step", 1, 0, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "foreach_step", 0), /* "Step" or begin next iteration of foreach loop. Assigns to foreach * iteration variables. May jump to straight after the foreach_start * that pushed the iterTracker and info values. MUST be followed * immediately by a foreach_end. * Stack: ... listObjs... iterTracker info => * ... listObjs... iterTracker info */ - {"foreach_end", 1, 0, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "foreach_end", 0), /* Clean up a foreach loop by dropping the info value, the tracker * value and the lists that were being iterated over. * Stack: ... listObjs... iterTracker info => ... */ - {"lmap_collect", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "lmap_collect", -1), /* Appends the value at the top of the stack to the list located on * the stack the "other side" of the foreach-related values. * Stack: ... collector listObjs... iterTracker info value => * ... collector listObjs... iterTracker info */ - {"strtrim", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "strtrim", -1), /* [string trim] core: removes the characters (designated by the value * at the top of the stack) from both ends of the string and pushes * the resulting string. * Stack: ... string charset => ... trimmedString */ - {"strtrimLeft", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "strtrimLeft", -1), /* [string trimleft] core: removes the characters (designated by the * value at the top of the stack) from the left of the string and * pushes the resulting string. * Stack: ... string charset => ... trimmedString */ - {"strtrimRight", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "strtrimRight", -1), /* [string trimright] core: removes the characters (designated by the * value at the top of the stack) from the right of the string and * pushes the resulting string. * Stack: ... string charset => ... trimmedString */ - {"concatStk", 5, INT_MIN, 1, {OPERAND_UINT4}}, + TCL_INSTRUCTION_ENTRY1( + "concatStk", 5, INT_MIN, OPERAND_UINT4), /* Wrapper round Tcl_ConcatObj(), used for [concat] and [eval]. opnd * is number of values to concatenate. * Operation: push concat(stk1 stk2 ... stktop) */ - {"strcaseUpper", 1, 0, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "strcaseUpper", 0), /* [string toupper] core: converts whole string to upper case using * the default (extended "C" locale) rules. * Stack: ... string => ... newString */ - {"strcaseLower", 1, 0, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "strcaseLower", 0), /* [string tolower] core: converts whole string to upper case using * the default (extended "C" locale) rules. * Stack: ... string => ... newString */ - {"strcaseTitle", 1, 0, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "strcaseTitle", 0), /* [string totitle] core: converts whole string to upper case using * the default (extended "C" locale) rules. * Stack: ... string => ... newString */ - {"strreplace", 1, -3, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "strreplace", -3), /* [string replace] core: replaces a non-empty range of one string * with the contents of another. * Stack: ... string fromIdx toIdx replacement => ... newString */ - {"originCmd", 1, 0, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "originCmd", 0), /* Reports which command was the origin (via namespace import chain) * of the command named on the top of the stack. * Stack: ... cmdName => ... fullOriginalCmdName */ - {"tclooNext", 2, INT_MIN, 1, {OPERAND_UINT1}}, + DEPRECATED_INSTRUCTION_ENTRY1( + "tclooNext", 2, INT_MIN, OPERAND_UINT1), /* Call the next item on the TclOO call chain, passing opnd arguments * (min 1, max 255, *includes* "next"). The result of the invoked * method implementation will be pushed on the stack in place of the * arguments (similar to invokeStk). * Stack: ... "next" arg2 arg3 -- argN => ... result */ - {"tclooNextClass", 2, INT_MIN, 1, {OPERAND_UINT1}}, + DEPRECATED_INSTRUCTION_ENTRY1( + "tclooNextClass", 2, INT_MIN, OPERAND_UINT1), /* Call the following item on the TclOO call chain defined by class * className, passing opnd arguments (min 2, max 255, *includes* * "nextto" and the class name). The result of the invoked method @@ -604,44 +798,54 @@ InstructionDesc const tclInstructionTable[] = { * arguments (similar to invokeStk). * Stack: ... "nextto" className arg3 arg4 -- argN => ... result */ - {"yieldToInvoke", 1, 0, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "yieldToInvoke", 0), /* Makes the current coroutine yield the value at the top of the * stack, invoking the given command/args with resolution in the given * namespace (all packed into a list), and places the list of values * that are the response back on top of the stack when it resumes. * Stack: ... [list ns cmd arg1 ... argN] => ... resumeList */ - {"numericType", 1, 0, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "numericType", 0), /* Pushes the numeric type code of the word at the top of the stack. * Stack: ... value => ... typeCode */ - {"tryCvtToBoolean", 1, +1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "tryCvtToBoolean", +1), /* Try converting stktop to boolean if possible. No errors. * Stack: ... value => ... value isStrictBool */ - {"strclass", 2, 0, 1, {OPERAND_SCLS1}}, + TCL_INSTRUCTION_ENTRY1( + "strclass", 2, 0, OPERAND_SCLS1), /* See if all the characters of the given string are a member of the * specified (by opnd) character class. Note that an empty string will * satisfy the class check (standard definition of "all"). * Stack: ... stringValue => ... boolean */ - {"lappendList", 5, 0, 1, {OPERAND_LVT4}}, + TCL_INSTRUCTION_ENTRY1( + "lappendList", 5, 0, OPERAND_LVT4), /* Lappend list to scalar variable at op4 in frame. * Stack: ... list => ... listVarContents */ - {"lappendListArray", 5, -1, 1, {OPERAND_LVT4}}, + TCL_INSTRUCTION_ENTRY1( + "lappendListArray", 5, -1, OPERAND_LVT4), /* Lappend list to array element; array at op4. * Stack: ... elem list => ... listVarContents */ - {"lappendListArrayStk", 1, -2, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "lappendListArrayStk", -2), /* Lappend list to array element. * Stack: ... arrayName elem list => ... listVarContents */ - {"lappendListStk", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "lappendListStk", -1), /* Lappend list to general variable. * Stack: ... varName list => ... listVarContents */ - {"clockRead", 2, +1, 1, {OPERAND_UINT1}}, + TCL_INSTRUCTION_ENTRY1( + "clockRead", 2, +1, OPERAND_CLK1), /* Read clock out to the stack. Operand is which clock to read * 0=clicks, 1=microseconds, 2=milliseconds, 3=seconds. * Stack: ... => ... time */ - {"dictGetDef", 5, INT_MIN, 1, {OPERAND_UINT4}}, + TCL_INSTRUCTION_ENTRY1( + "dictGetDef", 5, INT_MIN, OPERAND_UINT4), /* The top word is the default, the next op4 words (min 1) are a key * path into the dictionary just below the keys on the stack, and all * those values are replaced by the value read out of that key-path @@ -649,29 +853,141 @@ InstructionDesc const tclInstructionTable[] = { * default is pushed instead. * Stack: ... dict key1 ... keyN default => ... value */ - {"strlt", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "strlt", -1), /* String Less: push (stknext < stktop) */ - {"strgt", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "strgt", -1), /* String Greater: push (stknext > stktop) */ - {"strle", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "strle", -1), /* String Less or equal: push (stknext <= stktop) */ - {"strge", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "strge", -1), /* String Greater or equal: push (stknext >= stktop) */ - {"lreplace4", 6, INT_MIN, 2, {OPERAND_UINT4, OPERAND_UINT1}}, + TCL_INSTRUCTION_ENTRY2( + "lreplace", 6, INT_MIN, OPERAND_UINT4, OPERAND_LRPL1), /* Operands: number of arguments, flags - * flags: Combination of TCL_LREPLACE4_* flags + * flags: Combination of TCL_LREPLACE_* flags * Stack: ... listobj index1 ?index2? new1 ... newN => ... newlistobj * where index2 is present only if TCL_LREPLACE_SINGLE_INDEX is not - * set in flags. - */ + * set in flags. */ - {"constImm", 5, -1, 1, {OPERAND_LVT4}}, + TCL_INSTRUCTION_ENTRY1( + "constImm", 5, -1, OPERAND_LVT4), /* Create constant. Index into LVT is immediate, value is on stack. * Stack: ... value => ... */ - {"constStk", 1, -2, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "constStk", -2), /* Create constant. Variable name and value on stack. * Stack: ... varName value => ... */ + TCL_INSTRUCTION_ENTRY1( + "incrScalar", 5, 0, OPERAND_LVT4), + /* Incr scalar at index op1 in frame; incr amount is stktop */ + TCL_INSTRUCTION_ENTRY1( + "incrArray", 5, -1, OPERAND_LVT4), + /* Incr array elem; arr at slot op1, amount is top then elem */ + TCL_INSTRUCTION_ENTRY2( + "incrScalarImm", 6, +1, OPERAND_LVT4, OPERAND_INT1), + /* Incr scalar at slot op1; amount is 2nd operand byte */ + TCL_INSTRUCTION_ENTRY2( + "incrArrayImm", 6, 0, OPERAND_LVT4, OPERAND_INT1), + /* Incr array elem; array at slot op1, elem is stktop, + * amount is 2nd operand byte */ + TCL_INSTRUCTION_ENTRY1( + "tailcall", 5, INT_MIN, OPERAND_UINT4), + /* Do a tailcall with the opnd items on the stack as the thing to + * tailcall to; opnd must be greater than 0 for the semantics to work + * right. */ + TCL_INSTRUCTION_ENTRY1( + "tclooNext", 5, INT_MIN, OPERAND_UINT4), + /* Call the next item on the TclOO call chain, passing opnd arguments + * (min 1, *includes* "next"). The result of the invoked + * method implementation will be pushed on the stack in place of the + * arguments (similar to invokeStk). + * Stack: ... "next" arg2 arg3 -- argN => ... result */ + TCL_INSTRUCTION_ENTRY1( + "tclooNextClass", 5, INT_MIN, OPERAND_UINT4), + /* Call the following item on the TclOO call chain defined by class + * className, passing opnd arguments (min 2, *includes* + * "nextto" and the class name). The result of the invoked method + * implementation will be pushed on the stack in place of the + * arguments (similar to invokeStk). + * Stack: ... "nextto" className arg3 arg4 -- argN => ... result */ + + TCL_INSTRUCTION_ENTRY( + "swap", 0), + /* Exchanges the top two items on the stack. + * Stack: ... val1 val2 => ... val2 val1 */ + TCL_INSTRUCTION_ENTRY1( + "errorPrefixEq", 5, -1, OPERAND_UINT4), + /* Compare the two lists at stack top for equality in the first opnd + * words. The words are themselves compared using string equality. + * As: [string equal [lrange list1 0 opnd] [lrange list2 0 opnd]] + * Stack: ... list1 list2 => isEqual */ + TCL_INSTRUCTION_ENTRY( + "tclooId", 0), + /* Push the global ID of the TclOO object named at the top of the + * stack onto the stack. + * Stack: ... object => ... id */ + TCL_INSTRUCTION_ENTRY( + "dictPut", -2), + /* Modify the dict by replacing/creating the key/value pair given, + * pushing the result on the stack. + * Stack: ... dict key value => ... updatedDict */ + TCL_INSTRUCTION_ENTRY( + "dictRemove", -1), + /* Modify the dict by removing the key/value pair for the given key, + * pushing the result on the stack. + * Stack: ... dict key => ... updatedDict */ + TCL_INSTRUCTION_ENTRY( + "isEmpty", 0), + /* Test if the value at the top of the stack is empty (via a call to + * Tcl_IsEmpty). + * Stack: ... value => ... boolean */ + TCL_INSTRUCTION_ENTRY1( + "jumpTableNum", 5, -1, OPERAND_AUX4), + /* Jump according to the jump-table (in AuxData as indicated by the + * operand) and the argument popped from the list. Always executes the + * next instruction if no match against the table's entries was found. + * Keys are Tcl_WideInt. + * Stack: ... value => ... + * Note that the jump table contains offsets relative to the PC when + * it points to this instruction; the code is relocatable. */ + TCL_INSTRUCTION_ENTRY( + "tailcallList", 0), + /* Do a tailcall with the words from the argument as the thing to + * tailcall to, and currNs is the namespace scope. + * Stack: ... {currNs words...} => ...[NOT REACHED] */ + TCL_INSTRUCTION_ENTRY( + "tclooNextList", 0), + /* Call the next item on the TclOO call chain, passing the arguments + * from argumentList (min 1, *includes* "next"). The result of the + * invoked method implementation will be pushed on the stack after the + * target returns. + * Stack: ... argumentList => ... result */ + TCL_INSTRUCTION_ENTRY( + "tclooNextClassList", 0), + /* Call the following item on the TclOO call chain defined by class + * className, passing the arguments from argumentList (min 2, + * *includes* "nextto" and the class name). The result of the invoked + * method implementation will be pushed on the stack after the target + * returns. + * Stack: ... argumentList => ... result */ + TCL_INSTRUCTION_ENTRY1( + "arithSeries", 2, -3, OPERAND_UINT1), + /* Push a new arithSeries object on the stack. The opnd is a bit mask + * stating which values are valid; bit 0 -> from, bit 1 -> to, + * bit 2 -> step, bit 3 -> count. Invalid values are passed to + * TclNewArithSeriesObj() as NULL (and the corresponding values on the + * stack simply are ignored). + * Stack: ... from to step count => ... series */ + TCL_INSTRUCTION_ENTRY( + "uplevel", -1), + /* Call the script in the given stack level, and stack the result. + * Stack: ... level script => ... result */ + {NULL, 0, 0, 0, {OPERAND_NONE}} }; @@ -682,14 +998,15 @@ InstructionDesc const tclInstructionTable[] = { static void CleanupByteCode(ByteCode *codePtr); static ByteCode * CompileSubstObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); -static void DupByteCodeInternalRep(Tcl_Obj *srcPtr, - Tcl_Obj *copyPtr); +static void DupByteCodeInternalRep(Tcl_Obj *, Tcl_Obj *); static unsigned char * EncodeCmdLocMap(CompileEnv *envPtr, ByteCode *codePtr, unsigned char *startPtr); static void EnterCmdExtentData(CompileEnv *envPtr, - Tcl_Size cmdNumber, Tcl_Size numSrcBytes, Tcl_Size numCodeBytes); + Tcl_Size cmdNumber, Tcl_Size numSrcBytes, + Tcl_Size numCodeBytes); static void EnterCmdStartData(CompileEnv *envPtr, - Tcl_Size cmdNumber, Tcl_Size srcOffset, Tcl_Size codeOffset); + Tcl_Size cmdNumber, Tcl_Size srcOffset, + Tcl_Size codeOffset); static void FreeByteCodeInternalRep(Tcl_Obj *objPtr); static void FreeSubstCodeInternalRep(Tcl_Obj *objPtr); static int GetCmdLocEncodingSize(CompileEnv *envPtr); @@ -708,8 +1025,8 @@ static void StartExpanding(CompileEnv *envPtr); */ static void EnterCmdWordData(ExtCmdLoc *eclPtr, Tcl_Size srcOffset, Tcl_Token *tokenPtr, const char *cmd, - Tcl_Size numWords, Tcl_Size line, - Tcl_Size *clNext, Tcl_Size **lines, + Tcl_Size numWords, int line, + Tcl_Size *clNext, int **lines, CompileEnv *envPtr); static void ReleaseCmdWordData(ExtCmdLoc *eclPtr); @@ -779,7 +1096,7 @@ TclSetByteCodeFromAny( * compiled. Must not be NULL. */ Tcl_Obj *objPtr, /* The object to make a ByteCode object. */ CompileHookProc *hookProc, /* Procedure to invoke after compilation. */ - void *clientData) /* Hook procedure private data. */ + void *clientData) /* Hook procedure private data. */ { Interp *iPtr = (Interp *) interp; CompileEnv compEnv; /* Compilation environment structure allocated @@ -794,7 +1111,8 @@ TclSetByteCodeFromAny( if (!traceInitialized) { if (Tcl_LinkVar(interp, "tcl_traceCompile", &tclTraceCompile, TCL_LINK_INT) != TCL_OK) { - Tcl_Panic("SetByteCodeFromAny: unable to create link for tcl_traceCompile variable"); + Tcl_Panic("SetByteCodeFromAny: " + "unable to create link for tcl_traceCompile variable"); } traceInitialized = 1; } @@ -833,7 +1151,7 @@ TclSetByteCodeFromAny( * Compilation succeeded. Add a "done" instruction at the end. */ - TclEmitOpcode(INST_DONE, &compEnv); + TclEmitOpcode( INST_DONE, &compEnv); /* * Check for optimizations! @@ -856,7 +1174,7 @@ TclSetByteCodeFromAny( compEnv.atCmdStart = 2; /* The disabling magic. */ TclCompileScript(interp, stringPtr, length, &compEnv); assert (compEnv.atCmdStart > 1); - TclEmitOpcode(INST_DONE, &compEnv); + TclEmitOpcode( INST_DONE, &compEnv); assert (compEnv.atCmdStart > 1); } @@ -881,7 +1199,7 @@ TclSetByteCodeFromAny( * After optimization is all done, check that byte code length limits * are not exceeded. Bug [27b3ce2997]. */ - if ((compEnv.codeNext - compEnv.codeStart) > INT_MAX) { + if (CurrentOffset(&compEnv) > INT_MAX) { /* * Cannot just return TCL_ERROR as callers ignore return value. * TODO - May be use TclCompileSyntaxError here? @@ -991,7 +1309,7 @@ DupByteCodeInternalRep( static void FreeByteCodeInternalRep( - Tcl_Obj *objPtr) /* Object whose internal rep to free. */ + Tcl_Obj *objPtr) /* Object whose internal rep to free. */ { ByteCode *codePtr; @@ -1041,7 +1359,7 @@ TclReleaseByteCode( static void CleanupByteCode( - ByteCode *codePtr) /* Points to the ByteCode to free. */ + ByteCode *codePtr) /* Points to the ByteCode to free. */ { Tcl_Interp *interp = (Tcl_Interp *) *codePtr->interpHandle; Interp *iPtr = (Interp *) interp; @@ -1178,12 +1496,11 @@ IsCompactibleCompileEnv( * if it would otherwise be invalid. */ - if (envPtr->procPtr != NULL && envPtr->procPtr->cmdPtr != NULL - && envPtr->procPtr->cmdPtr->nsPtr != NULL) { + if (EnvIsProc(envPtr) && envPtr->procPtr->cmdPtr) { Namespace *nsPtr = envPtr->procPtr->cmdPtr->nsPtr; - if (strcmp(nsPtr->fullName, "::tcl") == 0 - || strncmp(nsPtr->fullName, "::tcl::", 7) == 0) { + if (nsPtr && (strcmp(nsPtr->fullName, "::tcl") == 0 + || strncmp(nsPtr->fullName, "::tcl::", 7) == 0)) { return 1; } } @@ -1200,7 +1517,7 @@ IsCompactibleCompileEnv( switch (*pc) { /* Invokes */ case INST_INVOKE_STK1: - case INST_INVOKE_STK4: + case INST_INVOKE_STK: case INST_INVOKE_EXPANDED: case INST_INVOKE_REPLACE: return 0; @@ -1349,7 +1666,7 @@ CompileSubstObj( TclSubstCompile(interp, bytes, numBytes, flags, 1, &compEnv); - TclEmitOpcode(INST_DONE, &compEnv); + TclEmitOpcode( INST_DONE, &compEnv); codePtr = TclInitByteCodeObj(objPtr, &substCodeType, &compEnv); TclFreeCompileEnv(&compEnv); @@ -1385,7 +1702,7 @@ CompileSubstObj( static void FreeSubstCodeInternalRep( - Tcl_Obj *objPtr) /* Object whose internal rep to free. */ + Tcl_Obj *objPtr) /* Object whose internal rep to free. */ { ByteCode *codePtr; @@ -1441,7 +1758,7 @@ TclInitCompileEnv( const char *stringPtr, /* The source string to be compiled. */ size_t numBytes, /* Number of bytes in source string. */ const CmdFrame *invoker, /* Location context invoking the bcc */ - int word) /* Index of the word in that context getting + Tcl_Size word) /* Index of the word in that context getting * compiled */ { Interp *iPtr = (Interp *) interp; @@ -1537,7 +1854,7 @@ TclInitCompileEnv( Tcl_IncrRefCount(envPtr->extCmdMapPtr->path); } else { envPtr->extCmdMapPtr->type = - (envPtr->procPtr ? TCL_LOCATION_PROC : TCL_LOCATION_BC); + (EnvIsProc(envPtr) ? TCL_LOCATION_PROC : TCL_LOCATION_BC); } } else { /* @@ -1568,7 +1885,7 @@ TclInitCompileEnv( envPtr->line = 1; envPtr->extCmdMapPtr->type = - (envPtr->procPtr ? TCL_LOCATION_PROC : TCL_LOCATION_BC); + (EnvIsProc(envPtr) ? TCL_LOCATION_PROC : TCL_LOCATION_BC); if (pc && (ctxPtr->type == TCL_LOCATION_SOURCE)) { /* @@ -1717,6 +2034,7 @@ TclFreeCompileEnv( * Side effects: * When returning true, appends the known value of the word to the * unshared Tcl_Obj (*valuePtr), unless valuePtr is NULL. + * NB: Does *NOT* manipulate the refCount of valuePtr. * *---------------------------------------------------------------------- */ @@ -1728,7 +2046,7 @@ TclWordKnownAtCompileTime( * to which we should append the known value * of the word. */ { - int numComponents = tokenPtr->numComponents; + Tcl_Size numComponents = tokenPtr->numComponents; Tcl_Obj *tempPtr = NULL; if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { @@ -1799,7 +2117,7 @@ TclWordKnownAtCompileTime( static int ExpandRequested( Tcl_Token *tokenPtr, - size_t numWords) + Tcl_Size numWords) { /* Determine whether any words of the command require expansion */ while (numWords--) { @@ -1817,23 +2135,18 @@ CompileCmdLiteral( Tcl_Obj *cmdObj, CompileEnv *envPtr) { - const char *bytes; Command *cmdPtr; int cmdLitIdx, extraLiteralFlags = LITERAL_CMD_NAME; - Tcl_Size length; cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj); if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_VIA_RESOLVER)) { extraLiteralFlags |= LITERAL_UNSHARED; } - bytes = TclGetStringFromObj(cmdObj, &length); - cmdLitIdx = TclRegisterLiteral(envPtr, bytes, length, extraLiteralFlags); - + cmdLitIdx = PUSH_OBJ_FLAGS(cmdObj, extraLiteralFlags); if (cmdPtr && TclRoutineHasName(cmdPtr)) { TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLitIdx), cmdPtr); } - TclEmitPush(cmdLitIdx, envPtr); } void @@ -1846,7 +2159,7 @@ TclCompileInvocation( { DefineLineInformation; size_t wordIdx = 0; - int depth = TclGetStackDepth(envPtr); + Tcl_Size depth = TclGetStackDepth(envPtr); if (cmdObj) { CompileCmdLiteral(interp, cmdObj, envPtr); @@ -1864,20 +2177,14 @@ TclCompileInvocation( continue; } - objIdx = TclRegisterLiteral(envPtr, - tokenPtr[1].start, tokenPtr[1].size, 0); + objIdx = PUSH_SIMPLE_TOKEN(tokenPtr); if (envPtr->clNext) { TclContinuationsEnterDerived(TclFetchLiteral(envPtr, objIdx), tokenPtr[1].start - envPtr->source, envPtr->clNext); } - TclEmitPush(objIdx, envPtr); } - if (wordIdx <= 255) { - TclEmitInvoke(envPtr, INST_INVOKE_STK1, wordIdx); - } else { - TclEmitInvoke(envPtr, INST_INVOKE_STK4, wordIdx); - } + INVOKE4( INVOKE_STK, wordIdx); TclCheckStackDepth(depth+1, envPtr); } @@ -1886,12 +2193,12 @@ CompileExpanded( Tcl_Interp *interp, Tcl_Token *tokenPtr, Tcl_Obj *cmdObj, - int numWords, + Tcl_Size numWords, CompileEnv *envPtr) { DefineLineInformation; - int wordIdx = 0; - int depth = TclGetStackDepth(envPtr); + Tcl_Size wordIdx = 0; + Tcl_Size depth = TclGetStackDepth(envPtr); StartExpanding(envPtr); if (cmdObj) { @@ -1908,19 +2215,16 @@ CompileExpanded( if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { CompileTokens(envPtr, tokenPtr, interp); if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { - TclEmitInstInt4(INST_EXPAND_STKTOP, - envPtr->currStackDepth, envPtr); + OP4( EXPAND_STKTOP, envPtr->currStackDepth); } continue; } - objIdx = TclRegisterLiteral(envPtr, - tokenPtr[1].start, tokenPtr[1].size, 0); + objIdx = PUSH_SIMPLE_TOKEN(tokenPtr); if (envPtr->clNext) { TclContinuationsEnterDerived(TclFetchLiteral(envPtr, objIdx), tokenPtr[1].start - envPtr->source, envPtr->clNext); } - TclEmitPush(objIdx, envPtr); } /* @@ -1937,8 +2241,8 @@ CompileExpanded( * prepared and run, INST_EXPAND_STKTOP is not stack-neutral in general. */ - TclEmitInvoke(envPtr, INST_INVOKE_EXPANDED, wordIdx); - TclCheckStackDepth(depth+1, envPtr); + INVOKE4( INVOKE_EXPANDED, wordIdx); + TclCheckStackDepth(depth + 1, envPtr); } static int @@ -1951,7 +2255,7 @@ CompileCmdCompileProc( DefineLineInformation; int unwind = 0; Tcl_Size incrOffset = -1; - int depth = TclGetStackDepth(envPtr); + Tcl_Size depth = TclGetStackDepth(envPtr); /* * Emission of the INST_START_CMD instruction is controlled by the value of @@ -1969,13 +2273,12 @@ CompileCmdCompileProc( switch (envPtr->atCmdStart) { case 0: unwind = tclInstructionTable[INST_START_CMD].numBytes; - TclEmitInstInt4(INST_START_CMD, 0, envPtr); - incrOffset = envPtr->codeNext - envPtr->codeStart; - TclEmitInt4(0, envPtr); + incrOffset = CurrentOffset(envPtr) + 5; + OP44( START_CMD, 0, 0); break; case 1: if (envPtr->codeNext > envPtr->codeStart) { - incrOffset = envPtr->codeNext - 4 - envPtr->codeStart; + incrOffset = CurrentOffset(envPtr) - 4; } break; case 2: @@ -2007,12 +2310,27 @@ CompileCmdCompileProc( /* * Throw out any line information generated by the failed compile attempt. + * Reset the index of next command. Toss out any from failed nested + * partial compiles. */ - while (mapPtr->nuloc - 1 > eclIndex) { - mapPtr->nuloc--; - Tcl_Free(mapPtr->loc[mapPtr->nuloc].line); - mapPtr->loc[mapPtr->nuloc].line = NULL; + ClearFailedCompile(envPtr); + return TCL_ERROR; +} + +void +TclClearFailedCompile( + CompileEnv *envPtr, + LineInformation *lineInfoPtr) +{ + /* + * Throw out any line information generated by the failed compile attempt. + */ + + while (lineInfoPtr->mapPtr->nuloc - 1 > lineInfoPtr->eclIndex) { + ECL *eclPtr = &lineInfoPtr->mapPtr->loc[--lineInfoPtr->mapPtr->nuloc]; + Tcl_Free(eclPtr->line); + eclPtr->line = NULL; } /* @@ -2020,11 +2338,10 @@ CompileCmdCompileProc( * partial compiles. */ - envPtr->numCommands = mapPtr->nuloc; - return TCL_ERROR; + envPtr->numCommands = lineInfoPtr->mapPtr->nuloc; } -static int +static Tcl_Size CompileCommandTokens( Tcl_Interp *interp, Tcl_Parse *parsePtr, @@ -2035,16 +2352,17 @@ CompileCommandTokens( ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; Tcl_Obj *cmdObj; Command *cmdPtr = NULL; - int code = TCL_ERROR; - int cmdKnown, expand = -1; - Tcl_Size *wlines, wlineat; + int code = TCL_ERROR, expand = -1; + int cmdKnown; + int *wlines; + Tcl_Size wlineat, numWords = parsePtr->numWords; Tcl_Size cmdLine = envPtr->line; Tcl_Size *clNext = envPtr->clNext; Tcl_Size cmdIdx = envPtr->numCommands; - Tcl_Size startCodeOffset = envPtr->codeNext - envPtr->codeStart; - int depth = TclGetStackDepth(envPtr); + Tcl_Size startCodeOffset = CurrentOffset(envPtr); + Tcl_Size depth = TclGetStackDepth(envPtr); - assert ((int)parsePtr->numWords > 0); + assert (numWords > 0); /* Precompile */ @@ -2055,14 +2373,13 @@ CompileCommandTokens( /* * TIP #280. Scan the words and compute the extended location information. - * At first the map first contains full per-word line information for use by the - * compiler. This is later replaced by a reduced form which signals + * At first the map first contains full per-word line information for use + * by the compiler. This is later replaced by a reduced form which signals * non-literal words, stored in 'wlines'. */ EnterCmdWordData(eclPtr, parsePtr->commandStart - envPtr->source, - parsePtr->tokenPtr, parsePtr->commandStart, - parsePtr->numWords, cmdLine, + parsePtr->tokenPtr, parsePtr->commandStart, numWords, cmdLine, clNext, &wlines, envPtr); wlineat = eclPtr->nuloc - 1; @@ -2089,7 +2406,7 @@ CompileCommandTokens( } } if (cmdPtr && !(cmdPtr->flags & CMD_COMPILES_EXPANDED)) { - expand = ExpandRequested(parsePtr->tokenPtr, (int)parsePtr->numWords); + expand = ExpandRequested(parsePtr->tokenPtr, numWords); if (expand) { /* We need to expand, but compileProc cannot. */ cmdPtr = NULL; @@ -2103,25 +2420,30 @@ CompileCommandTokens( } if (code == TCL_ERROR) { + /* + * We might have a failure to compile an expansion-aware command. If + * that's happened, expand will still be -1 and should be determined + * to be its true value now. + */ if (expand < 0) { - expand = ExpandRequested(parsePtr->tokenPtr, (int)parsePtr->numWords); + expand = ExpandRequested(parsePtr->tokenPtr, numWords); } if (expand) { CompileExpanded(interp, parsePtr->tokenPtr, - cmdKnown ? cmdObj : NULL, (int)parsePtr->numWords, envPtr); + cmdKnown ? cmdObj : NULL, numWords, envPtr); } else { TclCompileInvocation(interp, parsePtr->tokenPtr, - cmdKnown ? cmdObj : NULL, (int)parsePtr->numWords, envPtr); + cmdKnown ? cmdObj : NULL, numWords, envPtr); } } Tcl_DecrRefCount(cmdObj); - TclEmitOpcode(INST_POP, envPtr); + OP( POP); EnterCmdExtentData(envPtr, cmdIdx, parsePtr->term - parsePtr->commandStart, - (envPtr->codeNext-envPtr->codeStart) - startCodeOffset); + CurrentOffset(envPtr) - startCodeOffset); /* * TIP #280: Free the full form of per-word line data and insert the @@ -2150,12 +2472,14 @@ TclCompileScript( * first null character. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { - int lastCmdIdx = -1; /* Index into envPtr->cmdMapPtr of the last + Tcl_Size lastCmdIdx = TCL_INDEX_NONE; + /* Index into envPtr->cmdMapPtr of the last * command this routine compiles into bytecode. - * Initial value of -1 indicates this routine - * has not yet generated any bytecode. */ + * Initial value of TCL_INDEX_NONE indicates + * this routine has not yet generated any + * bytecode. */ const char *p = script; /* Where we are in our compile. */ - int depth = TclGetStackDepth(envPtr); + Tcl_Size depth = TclGetStackDepth(envPtr); Interp *iPtr = (Interp *) interp; if (envPtr->iPtr == NULL) { @@ -2170,7 +2494,8 @@ TclCompileScript( */ if (iPtr->numLevels / 5 > iPtr->maxNestingDepth / 4) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "too many nested compilations (infinite loop?)", -1)); + "too many nested compilations (infinite loop?)", + TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "LIMIT", "STACK", (char *)NULL); TclCompileSyntaxError(interp, envPtr); return; @@ -2191,7 +2516,7 @@ TclCompileScript( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "Script length %" TCL_SIZE_MODIFIER "d exceeds max permitted length %d.", - numBytes, INT_MAX-1)); + numBytes, INT_MAX - 1)); Tcl_SetErrorCode(interp, "TCL", "LIMIT", "SCRIPTLENGTH", (char *)NULL); TclCompileSyntaxError(interp, envPtr); return; @@ -2224,7 +2549,8 @@ TclCompileScript( * TODO: Suppress when numWords == 0 ? */ - if ((tclTraceCompile >= 1) && (envPtr->procPtr == NULL)) { + if ((tclTraceCompile >= TCL_TRACE_BYTECODE_COMPILE_SUMMARY) + && !EnvIsProc(envPtr)) { int commandLength = parsePtr->term - parsePtr->commandStart; fprintf(stdout, " Compiling: "); TclPrintSource(stdout, parsePtr->commandStart, @@ -2264,7 +2590,7 @@ TclCompileScript( * Tcl_FreeParse() to do. * * The advantage of this shortcut is that CompileCommandTokens() - * can be written with an assumption that (int)parsePtr->numWords > 0, with + * can be written with an assumption that parsePtr->numWords > 0, with * the implication the CCT() always generates bytecode. */ continue; @@ -2293,7 +2619,7 @@ TclCompileScript( Tcl_Free(parsePtr); } - if (lastCmdIdx == -1) { + if (lastCmdIdx == TCL_INDEX_NONE) { /* * Compiling the script yielded no bytecode. The script must be all * whitespace, comments, and empty commands. Such scripts are defined @@ -2301,7 +2627,7 @@ TclCompileScript( * simple bytecode that makes that happen. */ - PushStringLiteral(envPtr, ""); + PUSH( ""); } else { /* * We compiled at least one command to bytecode. The routine @@ -2378,7 +2704,7 @@ TclCompileVarSubst( * of local variables in a procedure frame. */ - localVar = -1; + localVar = TCL_INDEX_NONE; if (localVarName != -1) { localVar = TclFindCompiledLocal(name, nameBytes, localVarName, envPtr); } @@ -2395,20 +2721,16 @@ TclCompileVarSubst( if (tokenPtr->numComponents == 1) { if (localVar < 0) { - TclEmitOpcode(INST_LOAD_STK, envPtr); - } else if (localVar <= 255) { - TclEmitInstInt1(INST_LOAD_SCALAR1, localVar, envPtr); + OP( LOAD_STK); } else { - TclEmitInstInt4(INST_LOAD_SCALAR4, localVar, envPtr); + OP4( LOAD_SCALAR, localVar); } } else { TclCompileTokens(interp, tokenPtr+2, tokenPtr->numComponents-1, envPtr); if (localVar < 0) { - TclEmitOpcode(INST_LOAD_ARRAY_STK, envPtr); - } else if (localVar <= 255) { - TclEmitInstInt1(INST_LOAD_ARRAY1, localVar, envPtr); + OP( LOAD_ARRAY_STK); } else { - TclEmitInstInt4(INST_LOAD_ARRAY4, localVar, envPtr); + OP4( LOAD_ARRAY, localVar); } } } @@ -2426,13 +2748,13 @@ TclCompileTokens( * TCL_TOKEN_TEXT, TCL_TOKEN_BS tokens. */ char buffer[4] = ""; Tcl_Size i, numObjsToConcat, adjust; - int length; + Tcl_Size length; unsigned char *entryCodeNext = envPtr->codeNext; #define NUM_STATIC_POS 20 int isLiteral; Tcl_Size maxNumCL, numCL; Tcl_Size *clPosition = NULL; - int depth = TclGetStackDepth(envPtr); + Tcl_Size depth = TclGetStackDepth(envPtr); /* * If this is actually a literal, handle continuation lines by @@ -2496,7 +2818,7 @@ TclCompileTokens( if ((length == 1) && (buffer[0] == ' ') && (tokenPtr->start[1] == '\n')) { if (isLiteral) { - int clPos = Tcl_DStringLength(&textBuffer); + Tcl_Size clPos = Tcl_DStringLength(&textBuffer); if (numCL >= maxNumCL) { maxNumCL *= 2; @@ -2516,12 +2838,10 @@ TclCompileTokens( */ if (Tcl_DStringLength(&textBuffer) > 0) { - int literal = TclRegisterDStringLiteral(envPtr, &textBuffer); + int literal = TclPushDString(envPtr, &textBuffer); - TclEmitPush(literal, envPtr); numObjsToConcat++; Tcl_DStringFree(&textBuffer); - if (numCL) { TclContinuationsEnter(TclFetchLiteral(envPtr, literal), numCL, clPosition); @@ -2542,10 +2862,7 @@ TclCompileTokens( */ if (Tcl_DStringLength(&textBuffer) > 0) { - int literal; - - literal = TclRegisterDStringLiteral(envPtr, &textBuffer); - TclEmitPush(literal, envPtr); + TclPushDString(envPtr, &textBuffer); numObjsToConcat++; Tcl_DStringFree(&textBuffer); } @@ -2567,9 +2884,8 @@ TclCompileTokens( */ if (Tcl_DStringLength(&textBuffer) > 0) { - int literal = TclRegisterDStringLiteral(envPtr, &textBuffer); + int literal = TclPushDString(envPtr, &textBuffer); - TclEmitPush(literal, envPtr); numObjsToConcat++; if (numCL) { TclContinuationsEnter(TclFetchLiteral(envPtr, literal), @@ -2583,11 +2899,11 @@ TclCompileTokens( */ while (numObjsToConcat > 255) { - TclEmitInstInt1(INST_STR_CONCAT1, 255, envPtr); + OP1( STR_CONCAT1, 255); numObjsToConcat -= 254; /* concat pushes 1 obj, the result */ } if (numObjsToConcat > 1) { - TclEmitInstInt1(INST_STR_CONCAT1, numObjsToConcat, envPtr); + OP1( STR_CONCAT1, numObjsToConcat); } /* @@ -2595,7 +2911,7 @@ TclCompileTokens( */ if (envPtr->codeNext == entryCodeNext) { - PushStringLiteral(envPtr, ""); + PUSH( ""); } Tcl_DStringFree(&textBuffer); @@ -2656,7 +2972,7 @@ TclCompileCmdWord( */ TclCompileTokens(interp, tokenPtr, count, envPtr); - TclEmitInvoke(envPtr, INST_EVAL_STK); + INVOKE( EVAL_STK); } } @@ -2685,14 +3001,13 @@ TclCompileExprWords( Tcl_Interp *interp, /* Used for error and status reporting. */ Tcl_Token *tokenPtr, /* Points to first in an array of word tokens * for the expression to compile inline. */ - size_t numWords1, /* Number of word tokens starting at tokenPtr. + size_t numWords, /* Number of word tokens starting at tokenPtr. * Must be at least 1. Each word token * contains one or more subtokens. */ CompileEnv *envPtr) /* Holds the resulting instructions. */ { Tcl_Token *wordPtr; - int i, concatItems; - int numWords = numWords1; + size_t i, concatItems; /* * If the expression is a single word that doesn't require substitutions, @@ -2712,20 +3027,20 @@ TclCompileExprWords( wordPtr = tokenPtr; for (i = 0; i < numWords; i++) { CompileTokens(envPtr, wordPtr, interp); - if (i < (numWords - 1)) { - PushStringLiteral(envPtr, " "); + if (i + 1 < numWords) { + PUSH( " "); } wordPtr += wordPtr->numComponents + 1; } concatItems = 2*numWords - 1; while (concatItems > 255) { - TclEmitInstInt1(INST_STR_CONCAT1, 255, envPtr); + OP1( STR_CONCAT1, 255); concatItems -= 254; } if (concatItems > 1) { - TclEmitInstInt1(INST_STR_CONCAT1, concatItems, envPtr); + OP1( STR_CONCAT1, concatItems); } - TclEmitOpcode(INST_EXPR_STK, envPtr); + OP( EXPR_STK); } /* @@ -2763,10 +3078,10 @@ TclCompileNoOp( if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { CompileTokens(envPtr, tokenPtr, interp); - TclEmitOpcode(INST_POP, envPtr); + OP( POP); } } - PushStringLiteral(envPtr, ""); + PUSH( ""); return TCL_OK; } @@ -2829,7 +3144,7 @@ PreventCycle( ByteCode * TclInitByteCode( - CompileEnv *envPtr)/* Points to the CompileEnv structure from + CompileEnv *envPtr) /* Points to the CompileEnv structure from * which to create a ByteCode structure. */ { ByteCode *codePtr; @@ -2841,7 +3156,6 @@ TclInitByteCode( #endif Tcl_Size i, numLitObjects = envPtr->literalArrayNext; Namespace *namespacePtr; - int isNew; Interp *iPtr; if (envPtr->iPtr == NULL) { @@ -2850,7 +3164,7 @@ TclInitByteCode( iPtr = envPtr->iPtr; - codeBytes = envPtr->codeNext - envPtr->codeStart; + codeBytes = CurrentOffset(envPtr); objArrayBytes = envPtr->literalArrayNext * sizeof(Tcl_Obj *); exceptArrayBytes = envPtr->exceptArrayNext * sizeof(ExceptionRange); auxDataArrayBytes = envPtr->auxDataArrayNext * sizeof(AuxData); @@ -2935,7 +3249,9 @@ TclInitByteCode( #else nextPtr = EncodeCmdLocMap(envPtr, codePtr, (unsigned char *) p); if (((size_t)(nextPtr - p)) != cmdLocBytes) { - Tcl_Panic("TclInitByteCodeObj: encoded cmd location bytes %lu != expected size %lu", (unsigned long)(nextPtr - p), (unsigned long)cmdLocBytes); + Tcl_Panic("TclInitByteCodeObj: " + "encoded cmd location bytes %lu != expected size %lu", + (unsigned long)(nextPtr - p), (unsigned long)cmdLocBytes); } #endif @@ -2958,7 +3274,7 @@ TclInitByteCode( */ Tcl_SetHashValue(Tcl_CreateHashEntry(iPtr->lineBCPtr, codePtr, - &isNew), envPtr->extCmdMapPtr); + NULL), envPtr->extCmdMapPtr); envPtr->extCmdMapPtr = NULL; /* We've used up the CompileEnv. Mark as uninitialized. */ @@ -2974,7 +3290,7 @@ TclInitByteCodeObj( * and whose string rep contains the source * code. */ const Tcl_ObjType *typePtr, - CompileEnv *envPtr)/* Points to the CompileEnv structure from + CompileEnv *envPtr) /* Points to the CompileEnv structure from * which to create a ByteCode structure. */ { ByteCode *codePtr; @@ -3017,9 +3333,9 @@ TclInitByteCodeObj( *---------------------------------------------------------------------- */ -Tcl_Size +Tcl_LVTIndex TclFindCompiledLocal( - const char *name, /* Points to first character of the name of a + const char *name, /* Points to first character of the name of a * scalar or array variable. If NULL, a * temporary var should be created. */ Tcl_Size nameBytes, /* Number of bytes in the name. */ @@ -3089,7 +3405,8 @@ TclFindCompiledLocal( if (create || (name == NULL)) { localVar = procPtr->numCompiledLocals; - localPtr = (CompiledLocal *)Tcl_Alloc(offsetof(CompiledLocal, name) + 1U + nameBytes); + localPtr = (CompiledLocal *)Tcl_Alloc( + offsetof(CompiledLocal, name) + 1U + nameBytes); if (procPtr->firstLocalPtr == NULL) { procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr; } else { @@ -3148,7 +3465,7 @@ TclExpandCodeArray( * [inclusive]. */ - size_t currBytes = envPtr->codeNext - envPtr->codeStart; + size_t currBytes = CurrentOffset(envPtr); size_t newBytes = 2 * (envPtr->codeEnd - envPtr->codeStart); if (envPtr->mallocedCodeArray) { @@ -3198,12 +3515,13 @@ EnterCmdStartData( Tcl_Size cmdIndex, /* Index of the command whose start data is * being set. */ Tcl_Size srcOffset, /* Offset of first char of the command. */ - Tcl_Size codeOffset) /* Offset of first byte of command code. */ + Tcl_Size codeOffset) /* Offset of first byte of command code. */ { CmdLocation *cmdLocPtr; if (cmdIndex < 0 || cmdIndex >= envPtr->numCommands) { - Tcl_Panic("EnterCmdStartData: bad command index %" TCL_Z_MODIFIER "u", cmdIndex); + Tcl_Panic("EnterCmdStartData: bad command index %" TCL_Z_MODIFIER "u", + cmdIndex); } if (cmdIndex >= envPtr->cmdMapEnd) { @@ -3219,7 +3537,8 @@ EnterCmdStartData( size_t newBytes = newElems * sizeof(CmdLocation); if (envPtr->mallocedCmdMap) { - envPtr->cmdMapPtr = (CmdLocation *)Tcl_Realloc(envPtr->cmdMapPtr, newBytes); + envPtr->cmdMapPtr = (CmdLocation *)Tcl_Realloc(envPtr->cmdMapPtr, + newBytes); } else { /* * envPtr->cmdMapPtr isn't a Tcl_Alloc'd pointer, so we must code a @@ -3236,7 +3555,7 @@ EnterCmdStartData( } if (cmdIndex > 0) { - if (codeOffset < envPtr->cmdMapPtr[cmdIndex-1].codeOffset) { + if (codeOffset < envPtr->cmdMapPtr[cmdIndex - 1].codeOffset) { Tcl_Panic("EnterCmdStartData: cmd map not sorted by code offset"); } } @@ -3276,17 +3595,19 @@ EnterCmdExtentData( * location information. */ Tcl_Size cmdIndex, /* Index of the command whose source and code * length data is being set. */ - Tcl_Size numSrcBytes, /* Number of command source chars. */ - Tcl_Size numCodeBytes) /* Offset of last byte of command code. */ + Tcl_Size numSrcBytes, /* Number of command source chars. */ + Tcl_Size numCodeBytes) /* Offset of last byte of command code. */ { CmdLocation *cmdLocPtr; if (cmdIndex < 0 || cmdIndex >= envPtr->numCommands) { - Tcl_Panic("EnterCmdExtentData: bad command index %" TCL_Z_MODIFIER "u", cmdIndex); + Tcl_Panic("EnterCmdExtentData: bad command index %" TCL_Z_MODIFIER "u", + cmdIndex); } if (cmdIndex > envPtr->cmdMapEnd) { - Tcl_Panic("EnterCmdExtentData: missing start data for command %" TCL_Z_MODIFIER "u", + Tcl_Panic("EnterCmdExtentData: " + "missing start data for command %" TCL_Z_MODIFIER "u", cmdIndex); } @@ -3324,21 +3645,23 @@ EnterCmdWordData( Tcl_Token *tokenPtr, const char *cmd, Tcl_Size numWords, - Tcl_Size line, + int line, Tcl_Size *clNext, - Tcl_Size **wlines, + int **wlines, CompileEnv *envPtr) { ECL *ePtr; const char *last; - Tcl_Size wordIdx, wordLine; - Tcl_Size *wwlines, *wordNext; + Tcl_Size wordIdx; + int wordLine; + int *wwlines; + Tcl_Size *wordNext; if (eclPtr->nuloc >= eclPtr->nloc) { /* * Expand the ECL array by allocating more storage from the heap. The * currently allocated ECL entries are stored from eclPtr->loc[0] up - * to eclPtr->loc[eclPtr->nuloc-1] (inclusive). + * to eclPtr->loc[eclPtr->nuloc - 1] (inclusive). */ size_t currElems = eclPtr->nloc; @@ -3351,10 +3674,10 @@ EnterCmdWordData( ePtr = &eclPtr->loc[eclPtr->nuloc]; ePtr->srcOffset = srcOffset; - ePtr->line = (Tcl_Size *)Tcl_Alloc(numWords * sizeof(Tcl_Size)); + ePtr->line = (int *)Tcl_Alloc(numWords * sizeof(int)); ePtr->next = (Tcl_Size **)Tcl_Alloc(numWords * sizeof(Tcl_Size *)); ePtr->nline = numWords; - wwlines = (Tcl_Size *)Tcl_Alloc(numWords * sizeof(Tcl_Size)); + wwlines = (int *)Tcl_Alloc(numWords * sizeof(int)); last = cmd; wordLine = line; @@ -3397,10 +3720,10 @@ EnterCmdWordData( *---------------------------------------------------------------------- */ -Tcl_Size +Tcl_ExceptionRange TclCreateExceptRange( ExceptionRangeType type, /* The kind of ExceptionRange desired. */ - CompileEnv *envPtr)/* Points to CompileEnv for which to create a + CompileEnv *envPtr) /* Points to CompileEnv for which to create a * new ExceptionRange structure. */ { ExceptionRange *rangePtr; @@ -3422,10 +3745,10 @@ TclCreateExceptRange( size_t newBytes2 = newElems * sizeof(ExceptionAux); if (envPtr->mallocedExceptArray) { - envPtr->exceptArrayPtr = - (ExceptionRange *)Tcl_Realloc(envPtr->exceptArrayPtr, newBytes); - envPtr->exceptAuxArrayPtr = - (ExceptionAux *)Tcl_Realloc(envPtr->exceptAuxArrayPtr, newBytes2); + envPtr->exceptArrayPtr = (ExceptionRange *) + Tcl_Realloc(envPtr->exceptArrayPtr, newBytes); + envPtr->exceptAuxArrayPtr = (ExceptionAux *) + Tcl_Realloc(envPtr->exceptAuxArrayPtr, newBytes2); } else { /* * envPtr->exceptArrayPtr isn't a Tcl_Alloc'd pointer, so we must @@ -3494,9 +3817,9 @@ TclGetInnermostExceptionRange( rangePtr--; i--; - if (CurrentOffset(envPtr) >= (int)rangePtr->codeOffset && + if (CurrentOffset(envPtr) >= rangePtr->codeOffset && (rangePtr->numCodeBytes == TCL_INDEX_NONE || CurrentOffset(envPtr) < - (int)rangePtr->codeOffset+(int)rangePtr->numCodeBytes) && + rangePtr->codeOffset+rangePtr->numCodeBytes) && (returnCode != TCL_CONTINUE || envPtr->exceptAuxArrayPtr[i].supportsContinue)) { @@ -3516,7 +3839,7 @@ TclGetInnermostExceptionRange( * * Adds a place that wants to break/continue to the loop exception range * tracking that will be fixed up once the loop can be finalized. These - * functions generate an INST_JUMP4 that is fixed up during the + * functions generate an INST_JUMP that is fixed up during the * loop finalization. * * --------------------------------------------------------------------- @@ -3527,7 +3850,7 @@ TclAddLoopBreakFixup( CompileEnv *envPtr, ExceptionAux *auxPtr) { - int range = auxPtr - envPtr->exceptAuxArrayPtr; + Tcl_Size range = auxPtr - envPtr->exceptAuxArrayPtr; if (envPtr->exceptArrayPtr[range].type != LOOP_EXCEPTION_RANGE) { Tcl_Panic("trying to add 'break' fixup to full exception range"); @@ -3540,12 +3863,12 @@ TclAddLoopBreakFixup( auxPtr->breakTargets = (size_t *)Tcl_Realloc(auxPtr->breakTargets, sizeof(size_t) * auxPtr->allocBreakTargets); } else { - auxPtr->breakTargets = - (size_t *)Tcl_Alloc(sizeof(size_t) * auxPtr->allocBreakTargets); + auxPtr->breakTargets = (size_t *)Tcl_Alloc( + sizeof(size_t) * auxPtr->allocBreakTargets); } } auxPtr->breakTargets[auxPtr->numBreakTargets - 1] = CurrentOffset(envPtr); - TclEmitInstInt4(INST_JUMP4, 0, envPtr); + OP4( JUMP, 0); } void @@ -3553,7 +3876,7 @@ TclAddLoopContinueFixup( CompileEnv *envPtr, ExceptionAux *auxPtr) { - int range = auxPtr - envPtr->exceptAuxArrayPtr; + Tcl_Size range = auxPtr - envPtr->exceptAuxArrayPtr; if (envPtr->exceptArrayPtr[range].type != LOOP_EXCEPTION_RANGE) { Tcl_Panic("trying to add 'continue' fixup to full exception range"); @@ -3566,13 +3889,13 @@ TclAddLoopContinueFixup( auxPtr->continueTargets = (size_t *)Tcl_Realloc(auxPtr->continueTargets, sizeof(size_t) * auxPtr->allocContinueTargets); } else { - auxPtr->continueTargets = - (size_t *)Tcl_Alloc(sizeof(size_t) * auxPtr->allocContinueTargets); + auxPtr->continueTargets = (size_t *)Tcl_Alloc( + sizeof(size_t) * auxPtr->allocContinueTargets); } } auxPtr->continueTargets[auxPtr->numContinueTargets - 1] = CurrentOffset(envPtr); - TclEmitInstInt4(INST_JUMP4, 0, envPtr); + OP4( JUMP, 0); } /* @@ -3593,19 +3916,18 @@ TclCleanupStackForBreakContinue( ExceptionAux *auxPtr) { size_t savedStackDepth = envPtr->currStackDepth; - int toPop = envPtr->expandCount - auxPtr->expandTarget; + Tcl_Size toPop = envPtr->expandCount - auxPtr->expandTarget; if (toPop > 0) { while (toPop --> 0) { - TclEmitOpcode(INST_EXPAND_DROP, envPtr); + OP( EXPAND_DROP); } - TclAdjustStackDepth((int)(auxPtr->expandTargetDepth - envPtr->currStackDepth), - envPtr); + STKDELTA(auxPtr->expandTargetDepth - envPtr->currStackDepth); envPtr->currStackDepth = auxPtr->expandTargetDepth; } toPop = envPtr->currStackDepth - auxPtr->stackDepth; while (toPop --> 0) { - TclEmitOpcode(INST_POP, envPtr); + OP( POP); } envPtr->currStackDepth = savedStackDepth; } @@ -3626,16 +3948,16 @@ static void StartExpanding( CompileEnv *envPtr) { - int i; + Tcl_Size i; - TclEmitOpcode(INST_EXPAND_START, envPtr); + OP( EXPAND_START); /* * Update inner exception ranges with information about the environment * where this expansion started. */ - for (i=0 ; i<(int)envPtr->exceptArrayNext ; i++) { + for (i=0 ; i<envPtr->exceptArrayNext ; i++) { ExceptionRange *rangePtr = &envPtr->exceptArrayPtr[i]; ExceptionAux *auxPtr = &envPtr->exceptAuxArrayPtr[i]; @@ -3643,7 +3965,7 @@ StartExpanding( * Ignore loops unless they're still being built. */ - if ((int)rangePtr->codeOffset > CurrentOffset(envPtr)) { + if (rangePtr->codeOffset > CurrentOffset(envPtr)) { continue; } if (rangePtr->numCodeBytes != TCL_INDEX_NONE) { @@ -3683,11 +4005,11 @@ StartExpanding( void TclFinalizeLoopExceptionRange( CompileEnv *envPtr, - int range) + Tcl_ExceptionRange range) { ExceptionRange *rangePtr = &envPtr->exceptArrayPtr[range]; ExceptionAux *auxPtr = &envPtr->exceptAuxArrayPtr[range]; - int i, offset; + Tcl_Size i, offset; unsigned char *site; if (rangePtr->type != LOOP_EXCEPTION_RANGE) { @@ -3695,14 +4017,14 @@ TclFinalizeLoopExceptionRange( } /* - * Do the jump fixups. Note that these are always issued as INST_JUMP4 so + * Do the jump fixups. Note that these are always issued as INST_JUMP so * there is no need to fuss around with updating code offsets. */ - for (i=0 ; i<(int)auxPtr->numBreakTargets ; i++) { + for (i=0 ; i<auxPtr->numBreakTargets ; i++) { site = envPtr->codeStart + auxPtr->breakTargets[i]; offset = rangePtr->breakOffset - auxPtr->breakTargets[i]; - TclUpdateInstInt4AtPc(INST_JUMP4, offset, site); + TclUpdateInstInt4AtPc(INST_JUMP, offset, site); } for (i=0 ; i<(int)auxPtr->numContinueTargets ; i++) { site = envPtr->codeStart + auxPtr->continueTargets[i]; @@ -3720,7 +4042,7 @@ TclFinalizeLoopExceptionRange( } } else { offset = rangePtr->continueOffset - auxPtr->continueTargets[i]; - TclUpdateInstInt4AtPc(INST_JUMP4, offset, site); + TclUpdateInstInt4AtPc(INST_JUMP, offset, site); } } @@ -3759,18 +4081,17 @@ TclFinalizeLoopExceptionRange( *---------------------------------------------------------------------- */ -Tcl_Size +Tcl_AuxDataRef TclCreateAuxData( - void *clientData, /* The compilation auxiliary data to store in + void *clientData, /* The compilation auxiliary data to store in * the new aux data record. */ const AuxDataType *typePtr, /* Pointer to the type to attach to this * AuxData */ - CompileEnv *envPtr)/* Points to the CompileEnv for which a new + CompileEnv *envPtr) /* Points to the CompileEnv for which a new * aux data structure is to be allocated. */ { Tcl_Size index; /* Index for the new AuxData structure. */ - AuxData *auxDataPtr; - /* Points to the new AuxData structure */ + AuxData *auxDataPtr; /* Points to the new AuxData structure */ index = envPtr->auxDataArrayNext; if (index >= envPtr->auxDataArrayEnd) { @@ -3874,7 +4195,8 @@ TclExpandJumpFixupArray( size_t newBytes = newElems * sizeof(JumpFixup); if (fixupArrayPtr->mallocedArray) { - fixupArrayPtr->fixup = (JumpFixup *)Tcl_Realloc(fixupArrayPtr->fixup, newBytes); + fixupArrayPtr->fixup = (JumpFixup *)Tcl_Realloc(fixupArrayPtr->fixup, + newBytes); } else { /* * fixupArrayPtr->fixup isn't a Tcl_Alloc'd pointer, so we must code a @@ -3922,10 +4244,8 @@ TclFreeJumpFixupArray( * * TclEmitForwardJump -- * - * Emits a two-byte forward jump of kind "jumpType". Also initializes a - * JumpFixup record with information about the jump. Since may later be - * necessary to increase the size of the jump instruction to five bytes if - * the jump target is more than, say, 127 bytes away. + * Emits a five-byte forward jump of kind "jumpType". Also initializes a + * JumpFixup record with information about the jump. * * * Results: @@ -3933,9 +4253,8 @@ TclFreeJumpFixupArray( * * Side effects: * The JumpFixup record pointed to by "jumpFixupPtr" is initialized with - * information needed later if the jump is to be grown. Also, a two byte - * jump of the designated type is emitted at the current point in the - * bytecode stream. + * information needed later. Also, a five byte jump of the designated type + * is emitted at the current point in the bytecode stream. * *---------------------------------------------------------------------- */ @@ -3959,19 +4278,19 @@ TclEmitForwardJump( */ jumpFixupPtr->jumpType = jumpType; - jumpFixupPtr->codeOffset = envPtr->codeNext - envPtr->codeStart; + jumpFixupPtr->codeOffset = CurrentOffset(envPtr); jumpFixupPtr->cmdIndex = envPtr->numCommands; jumpFixupPtr->exceptIndex = envPtr->exceptArrayNext; switch (jumpType) { case TCL_UNCONDITIONAL_JUMP: - TclEmitInstInt1(INST_JUMP1, 0, envPtr); + OP4( JUMP, 0); break; case TCL_TRUE_JUMP: - TclEmitInstInt1(INST_JUMP_TRUE1, 0, envPtr); + OP4( JUMP_TRUE, 0); break; - default: - TclEmitInstInt1(INST_JUMP_FALSE1, 0, envPtr); + default: // TCL_FALSE_JUMP + OP4( JUMP_FALSE, 0); break; } } @@ -3982,138 +4301,39 @@ TclEmitForwardJump( * TclFixupForwardJump -- * * Modifies a previously-emitted forward jump to jump a specified number - * of bytes, "jumpDist". If necessary, the size of the jump instruction is - * increased from two to five bytes. This is done if the jump distance is - * greater than "distThreshold" (normally 127 bytes). The jump is - * described by a JumpFixup record previously initialized by - * TclEmitForwardJump. + * of bytes, "jumpDist". The jump is described by a JumpFixup record + * previously initialized by TclEmitForwardJump. * * Results: - * 1 if the jump was grown and subsequent instructions had to be moved, or - * 0 otherwsie. This allows callers to update any additional code offsets - * they may hold. + * None * * Side effects: - * The jump may be grown and subsequent instructions moved. If this - * happens, the code offsets for any commands and any ExceptionRange - * records between the jump and the current code address will be updated - * to reflect the moved code. Also, the bytecode instruction array in the - * CompileEnv structure may be grown and reallocated. + * None * *---------------------------------------------------------------------- */ -int +void TclFixupForwardJump( CompileEnv *envPtr, /* Points to the CompileEnv structure that * holds the resulting instruction. */ JumpFixup *jumpFixupPtr, /* Points to the JumpFixup structure that * describes the forward jump. */ - int jumpDist, /* Jump distance to set in jump instr. */ - int distThreshold) /* Maximum distance before the two byte jump - * is grown to five bytes. */ + Tcl_Size jumpDist) /* Jump distance to set in jump instr. */ { - unsigned char *jumpPc, *p; - int firstCmd, lastCmd, firstRange, lastRange, k; - size_t numBytes; - - if (jumpDist <= distThreshold) { - jumpPc = envPtr->codeStart + jumpFixupPtr->codeOffset; - switch (jumpFixupPtr->jumpType) { - case TCL_UNCONDITIONAL_JUMP: - TclUpdateInstInt1AtPc(INST_JUMP1, jumpDist, jumpPc); - break; - case TCL_TRUE_JUMP: - TclUpdateInstInt1AtPc(INST_JUMP_TRUE1, jumpDist, jumpPc); - break; - default: - TclUpdateInstInt1AtPc(INST_JUMP_FALSE1, jumpDist, jumpPc); - break; - } - return 0; - } - - /* - * Increase the size of the jump instruction, and then move subsequent - * instructions down. Expanding the space for generated instructions means - * that code addresses might change. Be careful about updating any of - * these addresses held in variables. - */ - - if ((envPtr->codeNext + 3) > envPtr->codeEnd) { - TclExpandCodeArray(envPtr); - } - jumpPc = envPtr->codeStart + jumpFixupPtr->codeOffset; - numBytes = envPtr->codeNext-jumpPc-2; - p = jumpPc+2; - memmove(p+3, p, numBytes); + unsigned char *jumpPc = envPtr->codeStart + jumpFixupPtr->codeOffset; - envPtr->codeNext += 3; - jumpDist += 3; switch (jumpFixupPtr->jumpType) { case TCL_UNCONDITIONAL_JUMP: - TclUpdateInstInt4AtPc(INST_JUMP4, jumpDist, jumpPc); + TclUpdateInstInt4AtPc( INST_JUMP, jumpDist, jumpPc); break; case TCL_TRUE_JUMP: - TclUpdateInstInt4AtPc(INST_JUMP_TRUE4, jumpDist, jumpPc); + TclUpdateInstInt4AtPc( INST_JUMP_TRUE, jumpDist, jumpPc); break; - default: - TclUpdateInstInt4AtPc(INST_JUMP_FALSE4, jumpDist, jumpPc); + default: // TCL_FALSE_JUMP + TclUpdateInstInt4AtPc( INST_JUMP_FALSE, jumpDist, jumpPc); break; } - - /* - * Adjust the code offsets for any commands and any ExceptionRange records - * between the jump and the current code address. - */ - - firstCmd = jumpFixupPtr->cmdIndex; - lastCmd = envPtr->numCommands - 1; - if (firstCmd < lastCmd) { - for (k = firstCmd; k <= lastCmd; k++) { - envPtr->cmdMapPtr[k].codeOffset += 3; - } - } - - firstRange = jumpFixupPtr->exceptIndex; - lastRange = envPtr->exceptArrayNext - 1; - for (k = firstRange; k <= lastRange; k++) { - ExceptionRange *rangePtr = &envPtr->exceptArrayPtr[k]; - - rangePtr->codeOffset += 3; - switch (rangePtr->type) { - case LOOP_EXCEPTION_RANGE: - rangePtr->breakOffset += 3; - if (rangePtr->continueOffset != TCL_INDEX_NONE) { - rangePtr->continueOffset += 3; - } - break; - case CATCH_EXCEPTION_RANGE: - rangePtr->catchOffset += 3; - break; - default: - Tcl_Panic("TclFixupForwardJump: bad ExceptionRange type %d", - rangePtr->type); - } - } - - for (k = 0 ; k < (int)envPtr->exceptArrayNext ; k++) { - ExceptionAux *auxPtr = &envPtr->exceptAuxArrayPtr[k]; - int i; - - for (i=0 ; i<(int)auxPtr->numBreakTargets ; i++) { - if (jumpFixupPtr->codeOffset < auxPtr->breakTargets[i]) { - auxPtr->breakTargets[i] += 3; - } - } - for (i=0 ; i<(int)auxPtr->numContinueTargets ; i++) { - if (jumpFixupPtr->codeOffset < auxPtr->continueTargets[i]) { - auxPtr->continueTargets[i] += 3; - } - } - } - - return 1; /* the jump was grown */ } /* @@ -4126,6 +4346,8 @@ TclFixupForwardJump( * through it gets the stack unwinding correct, converting it into an * internal jump if in an appropriate context. * + * Handles the instructions that can generate TCL_BREAK or TCL_CONTINUE. + * * Results: * None * @@ -4146,9 +4368,9 @@ TclEmitInvoke( va_list argList; ExceptionRange *rangePtr; ExceptionAux *auxBreakPtr, *auxContinuePtr; - int arg1, arg2, wordCount = 0, expandCount = 0; - int loopRange = 0, breakRange = 0, continueRange = 0; - int cleanup, depth = TclGetStackDepth(envPtr); + Tcl_Size arg1, arg2, wordCount = 0, expandCount = 0; + Tcl_ExceptionRange loopRange = 0, breakRange = 0, continueRange = 0; + Tcl_Size cleanup, depth = TclGetStackDepth(envPtr); /* * Parse the arguments. @@ -4156,11 +4378,17 @@ TclEmitInvoke( va_start(argList, opcode); switch (opcode) { +#ifndef TCL_NO_DEPRECATED + case INST_TCLOO_NEXT1: + case INST_TCLOO_NEXT_CLASS1: case INST_INVOKE_STK1: wordCount = arg1 = cleanup = va_arg(argList, int); arg2 = 0; break; - case INST_INVOKE_STK4: +#endif + case INST_TCLOO_NEXT: + case INST_TCLOO_NEXT_CLASS: + case INST_INVOKE_STK: wordCount = arg1 = cleanup = va_arg(argList, int); arg2 = 0; break; @@ -4170,13 +4398,16 @@ TclEmitInvoke( wordCount = arg1 + arg2 - 1; cleanup = arg1 + 1; break; - default: - Tcl_Panic("unexpected opcode"); + case INST_YIELD: + case INST_YIELD_TO_INVOKE: case INST_EVAL_STK: + case INST_TCLOO_NEXT_LIST: + case INST_TCLOO_NEXT_CLASS_LIST: wordCount = cleanup = 1; arg1 = arg2 = 0; break; case INST_RETURN_STK: + case INST_UPLEVEL: wordCount = cleanup = 2; arg1 = arg2 = 0; break; @@ -4185,6 +4416,9 @@ TclEmitInvoke( arg2 = 0; expandCount = 1; break; + default: + Tcl_Panic("opcode %s not handled by TclEmitInvoke()", + tclInstructionTable[opcode].name); } va_end(argList); @@ -4219,7 +4453,7 @@ TclEmitInvoke( } if (auxBreakPtr != NULL || auxContinuePtr != NULL) { - loopRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); + loopRange = MAKE_LOOP_RANGE(); ExceptionRangeStarts(envPtr, loopRange); } @@ -4228,28 +4462,60 @@ TclEmitInvoke( */ switch (opcode) { +#ifndef TCL_NO_DEPRECATED case INST_INVOKE_STK1: - TclEmitInstInt1(INST_INVOKE_STK1, arg1, envPtr); + OP1( INVOKE_STK1, arg1); break; - case INST_INVOKE_STK4: - TclEmitInstInt4(INST_INVOKE_STK4, arg1, envPtr); +#endif + case INST_INVOKE_STK: + OP4( INVOKE_STK, arg1); break; case INST_INVOKE_EXPANDED: - TclEmitOpcode(INST_INVOKE_EXPANDED, envPtr); + OP( INVOKE_EXPANDED); envPtr->expandCount--; - TclAdjustStackDepth(1 - arg1, envPtr); + STKDELTA(1 - arg1); break; case INST_EVAL_STK: - TclEmitOpcode(INST_EVAL_STK, envPtr); + OP( EVAL_STK); break; case INST_RETURN_STK: - TclEmitOpcode(INST_RETURN_STK, envPtr); + OP( RETURN_STK); break; case INST_INVOKE_REPLACE: - TclEmitInstInt4(INST_INVOKE_REPLACE, arg1, envPtr); - TclEmitInt1(arg2, envPtr); - TclAdjustStackDepth(-1, envPtr); /* Correction to stack depth calcs */ + OP41( INVOKE_REPLACE, arg1, arg2); + break; +#ifndef TCL_NO_DEPRECATED + case INST_TCLOO_NEXT1: + OP1( TCLOO_NEXT1, arg1); + break; + case INST_TCLOO_NEXT_CLASS1: + OP1( TCLOO_NEXT_CLASS1, arg1); + break; +#endif + case INST_TCLOO_NEXT: + OP4( TCLOO_NEXT, arg1); + break; + case INST_TCLOO_NEXT_LIST: + OP( TCLOO_NEXT_LIST); break; + case INST_TCLOO_NEXT_CLASS: + OP4( TCLOO_NEXT_CLASS, arg1); + break; + case INST_TCLOO_NEXT_CLASS_LIST: + OP( TCLOO_NEXT_CLASS_LIST); + break; + case INST_UPLEVEL: + OP( UPLEVEL); + break; + case INST_YIELD: + OP( YIELD); + break; + case INST_YIELD_TO_INVOKE: + OP( YIELD_TO_INVOKE); + break; + default: + Tcl_Panic("opcode %s not handled by TclEmitInvoke()", + tclInstructionTable[opcode].name); } /* @@ -4260,7 +4526,7 @@ TclEmitInvoke( if (auxBreakPtr != NULL || auxContinuePtr != NULL) { size_t savedStackDepth = envPtr->currStackDepth; size_t savedExpandCount = envPtr->expandCount; - JumpFixup nonTrapFixup; + Tcl_BytecodeLabel noTrap; if (auxBreakPtr != NULL) { auxBreakPtr = envPtr->exceptAuxArrayPtr + breakRange; @@ -4270,7 +4536,7 @@ TclEmitInvoke( } ExceptionRangeEnds(envPtr, loopRange); - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &nonTrapFixup); + FWDJUMP( JUMP, noTrap); /* * Careful! When generating these stack unwinding sequences, the depth @@ -4279,31 +4545,31 @@ TclEmitInvoke( */ if (auxBreakPtr != NULL) { - TclAdjustStackDepth(-1, envPtr); + STKDELTA(-1); - ExceptionRangeTarget(envPtr, loopRange, breakOffset); + BREAK_TARGET( loopRange); TclCleanupStackForBreakContinue(envPtr, auxBreakPtr); TclAddLoopBreakFixup(envPtr, auxBreakPtr); - TclAdjustStackDepth(1, envPtr); + STKDELTA(1); envPtr->currStackDepth = savedStackDepth; envPtr->expandCount = savedExpandCount; } if (auxContinuePtr != NULL) { - TclAdjustStackDepth(-1, envPtr); + STKDELTA(-1); - ExceptionRangeTarget(envPtr, loopRange, continueOffset); + CONTINUE_TARGET( loopRange); TclCleanupStackForBreakContinue(envPtr, auxContinuePtr); TclAddLoopContinueFixup(envPtr, auxContinuePtr); - TclAdjustStackDepth(1, envPtr); + STKDELTA(1); envPtr->currStackDepth = savedStackDepth; envPtr->expandCount = savedExpandCount; } - TclFinalizeLoopExceptionRange(envPtr, loopRange); - TclFixupForwardJumpToHere(envPtr, &nonTrapFixup, 127); + FINALIZE_LOOP( loopRange); + FWDLABEL( noTrap); } TclCheckStackDepth(depth+1-cleanup, envPtr); } @@ -4357,13 +4623,13 @@ GetCmdLocEncodingSize( * encode. */ { CmdLocation *mapPtr = envPtr->cmdMapPtr; - int numCmds = envPtr->numCommands; - int codeDelta, codeLen, srcDelta, srcLen; + Tcl_Size numCmds = envPtr->numCommands; + Tcl_Size codeDelta, codeLen, srcDelta, srcLen; int codeDeltaNext, codeLengthNext, srcDeltaNext, srcLengthNext; /* The offsets in their respective byte * sequences where the next encoded offset or * length should go. */ - int prevCodeOffset, prevSrcOffset, i; + Tcl_Size prevCodeOffset, prevSrcOffset, i; codeDeltaNext = codeLengthNext = srcDeltaNext = srcLengthNext = 0; prevCodeOffset = prevSrcOffset = 0; @@ -4444,7 +4710,7 @@ EncodeCmdLocMap( Tcl_Size i, codeDelta, codeLen, srcLen, prevOffset; Tcl_Size numCmds = envPtr->numCommands; unsigned char *p = startPtr; - int srcDelta; + Tcl_Size srcDelta; /* * Encode the code offset for each command as a sequence of deltas. @@ -4531,6 +4797,324 @@ EncodeCmdLocMap( return p; } +/* + *---------------------------------------------------------------------- + * + * TclIsEmptyToken -- + * + * Test if the token is empty. + * + * We don't test if it's just comments. Fixes are welcome. + * + * Results: + * True iff the token (assumed a TCL_TOKEN_SIMPLE_TEXT) only contains + * whitespace of the kind that never results in code being generated. + * False otherwise. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ +int +TclIsEmptyToken( + const Tcl_Token *tokenPtr) +{ + const char *ptr, *end; + int ucs4, chLen = 0; + + end = tokenPtr[1].start + tokenPtr[1].size; + for (ptr = tokenPtr[1].start; ptr < end; ptr += chLen) { + chLen = TclUtfToUniChar(ptr, &ucs4); + // Can't use Tcl_UniCharIsSpace; see test dict-22.24 + if (!TclIsSpaceProcM((unsigned) ucs4)) { + return 0; + } + } + return 1; +} + +/* + *---------------------------------------------------------------------- + * + * TclLocalScalarFromToken -- + * + * Get the index into the table of compiled locals that corresponds + * to a local scalar variable name. + * + * Results: + * Returns the non-negative integer index value into the table of + * compiled locals corresponding to a local scalar variable name. + * If the arguments passed in do not identify a local scalar variable + * then return TCL_INDEX_NONE. + * + * Side effects: + * May add an entry into the table of compiled locals. + * + *---------------------------------------------------------------------- + */ + +Tcl_Size +TclLocalScalarFromToken( + Tcl_Token *tokenPtr, + CompileEnv *envPtr) +{ + int isScalar; + Tcl_LVTIndex index; + + TclPushVarName(NULL, tokenPtr, envPtr, TCL_NO_ELEMENT, &index, &isScalar); + if (!isScalar) { + index = TCL_INDEX_NONE; + } + return index; +} + +Tcl_Size +TclLocalScalar( + const char *bytes, + size_t numBytes, + CompileEnv *envPtr) +{ + Tcl_Token token[2] = { + {TCL_TOKEN_SIMPLE_WORD, NULL, 0, 1}, + {TCL_TOKEN_TEXT, NULL, 0, 0} + }; + + token[1].start = bytes; + token[1].size = numBytes; + return TclLocalScalarFromToken(token, envPtr); +} + +/* + *---------------------------------------------------------------------- + * + * TclPushVarName -- + * + * Procedure used in the compiling where pushing a variable name is + * necessary (append, lappend, set). + * + * Results: + * The values written to *localIndexPtr and *isScalarPtr signal to + * the caller what the instructions emitted by this routine will do: + * + * *isScalarPtr (*localIndexPtr < 0) + * 1 1 Push the varname on the stack. (Stack +1) + * 1 0 *localIndexPtr is the index of the compiled + * local for this varname. No instructions + * emitted. (Stack +0) + * 0 1 Push part1 and part2 names of array element + * on the stack. (Stack +2) + * 0 0 *localIndexPtr is the index of the compiled + * local for this array. Element name is pushed + * on the stack. (Stack +1) + * + * Side effects: + * Instructions are added to envPtr. + * + *---------------------------------------------------------------------- + */ + +void +TclPushVarName( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Token *varTokenPtr, /* Points to a variable token. */ + CompileEnv *envPtr, /* Holds resulting instructions. */ + int flags, /* TCL_NO_ELEMENT. */ + Tcl_Size *localIndexPtr, /* Must not be NULL. */ + int *isScalarPtr) /* Must not be NULL. */ +{ + const char *p; + const char *last, *name, *elName; + Tcl_Token *elemTokenPtr = NULL; + Tcl_Size nameLen, elNameLen, n; + int simpleVarName = 0, allocedTokens = 0; + Tcl_Size elemTokenCount = 0, removedParen = 0; + Tcl_LVTIndex localIndex; + + /* + * Decide if we can use a frame slot for the var/array name or if we need + * to emit code to compute and push the name at runtime. We use a frame + * slot (entry in the array of local vars) if we are compiling a procedure + * body and if the name is simple text that does not include namespace + * qualifiers. + */ + + name = elName = NULL; + nameLen = elNameLen = 0; + localIndex = TCL_INDEX_NONE; + + if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + /* + * A simple variable name. Divide it up into "name" and "elName" + * strings. If it is not a local variable, look it up at runtime. + */ + + simpleVarName = 1; + + name = varTokenPtr[1].start; + nameLen = varTokenPtr[1].size; + if (name[nameLen - 1] == ')') { + /* + * last char is ')' => potential array reference. + */ + last = &name[nameLen - 1]; + + if (*last == ')') { + for (p = name; p < last; p++) { + if (*p == '(') { + elName = p + 1; + elNameLen = last - elName; + nameLen = p - name; + break; + } + } + } + + if (!(flags & TCL_NO_ELEMENT) && elNameLen) { + /* + * An array element, the element name is a simple string: + * assemble the corresponding token. + */ + + elemTokenPtr = (Tcl_Token *)TclStackAlloc(interp, sizeof(Tcl_Token)); + allocedTokens = 1; + elemTokenPtr->type = TCL_TOKEN_TEXT; + elemTokenPtr->start = elName; + elemTokenPtr->size = elNameLen; + elemTokenPtr->numComponents = 0; + elemTokenCount = 1; + } + } + } else if (interp && ((n = varTokenPtr->numComponents) > 1) + && (varTokenPtr[1].type == TCL_TOKEN_TEXT) + && (varTokenPtr[n].type == TCL_TOKEN_TEXT) + && (varTokenPtr[n].start[varTokenPtr[n].size - 1] == ')')) { + /* + * Check for parentheses inside first token. + */ + + simpleVarName = 0; + for (p = varTokenPtr[1].start, last = p + varTokenPtr[1].size; + p < last; p++) { + if (*p == '(') { + simpleVarName = 1; + break; + } + } + if (simpleVarName) { + size_t remainingLen; + + /* + * Check the last token: if it is just ')', do not count it. + * Otherwise, remove the ')' and flag so that it is restored at + * the end. + */ + + if (varTokenPtr[n].size == 1) { + n--; + } else { + varTokenPtr[n].size--; + removedParen = n; + } + + name = varTokenPtr[1].start; + nameLen = p - varTokenPtr[1].start; + elName = p + 1; + remainingLen = (varTokenPtr[2].start - p) - 1; + elNameLen = (varTokenPtr[n].start-p) + varTokenPtr[n].size - 1; + + if (!(flags & TCL_NO_ELEMENT)) { + if (remainingLen) { + /* + * Make a first token with the extra characters in the + * first token. + */ + + elemTokenPtr = (Tcl_Token *)TclStackAlloc(interp, + n * sizeof(Tcl_Token)); + allocedTokens = 1; + elemTokenPtr->type = TCL_TOKEN_TEXT; + elemTokenPtr->start = elName; + elemTokenPtr->size = remainingLen; + elemTokenPtr->numComponents = 0; + elemTokenCount = n; + + /* + * Copy the remaining tokens. + */ + + memcpy(elemTokenPtr + 1, varTokenPtr + 2, + (n - 1) * sizeof(Tcl_Token)); + } else { + /* + * Use the already available tokens. + */ + + elemTokenPtr = &varTokenPtr[2]; + elemTokenCount = n - 1; + } + } + } + } + + if (simpleVarName) { + /* + * See whether name has any namespace separators (::'s). + */ + + int hasNsQualifiers = 0; + + for (p = name, last = p + nameLen-1; p < last; p++) { + if ((p[0] == ':') && (p[1] == ':')) { + hasNsQualifiers = 1; + break; + } + } + + /* + * Look up the var name's index in the array of local vars in the proc + * frame. If retrieving the var's value and it doesn't already exist, + * push its name and look it up at runtime. + */ + + if (!hasNsQualifiers) { + localIndex = TclFindCompiledLocal(name, nameLen, 1, envPtr); + } + if (interp && localIndex < 0) { + PushLiteral(envPtr, name, nameLen); + } + + /* + * Compile the element script, if any, and only if not inhibited. [Bug + * 3600328] + */ + + if (elName != NULL && !(flags & TCL_NO_ELEMENT)) { + if (elNameLen) { + TclCompileTokens(interp, elemTokenPtr, elemTokenCount, + envPtr); + } else { + PUSH( ""); + } + } + } else if (interp) { + /* + * The var name isn't simple: compile and push it. + */ + + CompileTokens(envPtr, varTokenPtr, interp); + } + + if (removedParen) { + varTokenPtr[removedParen].size++; + } + if (allocedTokens) { + TclStackFree(interp, elemTokenPtr); + } + *localIndexPtr = localIndex; + *isScalarPtr = (elName == NULL); +} + #ifdef TCL_COMPILE_STATS /* *---------------------------------------------------------------------- diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 245a891..7f2596a 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -5,6 +5,7 @@ * Copyright (c) 1998-2000 by Scriptics Corporation. * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net> + * Copyright (c) 2025 Donal K. Fellows <dkf@users.sourceforge.net> * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -36,6 +37,12 @@ struct ByteCode; /* Forward declaration. */ MODULE_SCOPE int tclTraceCompile; +enum TclTraceBytecodeCompileLevels { + TCL_TRACE_BYTECODE_COMPILE_NONE = 0, + TCL_TRACE_BYTECODE_COMPILE_SUMMARY = 1, + TCL_TRACE_BYTECODE_COMPILE_DETAIL = 2 +}; + /* * Variable that controls whether execution tracing is enabled and, if so, * what level of tracing is desired: @@ -47,6 +54,13 @@ MODULE_SCOPE int tclTraceCompile; */ MODULE_SCOPE int tclTraceExec; + +enum TclTraceBytecodeExecLevels { + TCL_TRACE_BYTECODE_EXEC_NONE = 0, + TCL_TRACE_BYTECODE_EXEC_PROCS = 1, + TCL_TRACE_BYTECODE_EXEC_COMMANDS = 2, + TCL_TRACE_BYTECODE_EXEC_INSTRUCTIONS = 3 +}; #endif /* @@ -63,6 +77,21 @@ MODULE_SCOPE const Tcl_ObjType tclLambdaType; */ /* + * The type of indices into the local variable table. + */ +typedef Tcl_Size Tcl_LVTIndex; + +/* + * The type of handles made by TclCreateAuxData() + */ +typedef Tcl_Size Tcl_AuxDataRef; + +/* + * The type of "catch ranges" returned from TclCreateExceptRange(), etc. + */ +typedef Tcl_Size Tcl_ExceptionRange; + +/* * The structure used to implement Tcl "exceptions" (exceptional returns): for * example, those generated in loops by the break and continue commands, and * those generated by scripts and caught by the catch command. This @@ -87,7 +116,7 @@ typedef enum { * to a catch PC offset. */ } ExceptionRangeType; -typedef struct { +typedef struct ExceptionRange { ExceptionRangeType type; /* The kind of ExceptionRange. */ Tcl_Size nestingLevel; /* Static depth of the exception range. Used * to find the most deeply-nested range @@ -135,7 +164,7 @@ typedef struct ExceptionAux { Tcl_Size numBreakTargets; /* The number of [break]s that want to be * targeted to the place where this loop * exception will be bound to. */ - TCL_HASH_TYPE *breakTargets;/* The offsets of the INST_JUMP4 instructions + size_t *breakTargets; /* The offsets of the INST_JUMP instructions * issued by the [break]s that we must * update. Note that resizing a jump (via * TclFixupForwardJump) can cause the contents @@ -145,8 +174,7 @@ typedef struct ExceptionAux { Tcl_Size numContinueTargets;/* The number of [continue]s that want to be * targeted to the place where this loop * exception will be bound to. */ - TCL_HASH_TYPE *continueTargets; - /* The offsets of the INST_JUMP4 instructions + size_t *continueTargets; /* The offsets of the INST_JUMP instructions * issued by the [continue]s that we must * update. Note that resizing a jump (via * TclFixupForwardJump) can cause the contents @@ -164,7 +192,7 @@ typedef struct ExceptionAux { * source offset is not monotonic. */ -typedef struct { +typedef struct CmdLocation { Tcl_Size codeOffset; /* Offset of first byte of command code. */ Tcl_Size numCodeBytes; /* Number of bytes for command's code. */ Tcl_Size srcOffset; /* Offset of first char of the command. */ @@ -182,17 +210,17 @@ typedef struct { * frame and associated information, like the path of a sourced file. */ -typedef struct { +typedef struct ECL { Tcl_Size srcOffset; /* Command location to find the entry. */ Tcl_Size nline; /* Number of words in the command */ - Tcl_Size *line; /* Line information for all words in the + int *line; /* Line information for all words in the * command. */ Tcl_Size **next; /* Transient information used by the compiler * for tracking of hidden continuation * lines. */ } ECL; -typedef struct { +typedef struct ExtCmdLoc { int type; /* Context type. */ Tcl_Size start; /* Starting line for compiled script. Needed * for the extended recompile check in @@ -223,7 +251,7 @@ typedef void * (AuxDataDupProc) (void *clientData); typedef void (AuxDataFreeProc) (void *clientData); typedef void (AuxDataPrintProc) (void *clientData, Tcl_Obj *appendObj, struct ByteCode *codePtr, - TCL_HASH_TYPE pcOffset); + size_t pcOffset); /* * We define a separate AuxDataType struct to hold type-related information @@ -320,10 +348,8 @@ typedef struct CompileEnv { * array byte. */ int mallocedCodeArray; /* Set 1 if code array was expanded and * codeStart points into the heap.*/ -#if TCL_MAJOR_VERSION > 8 int mallocedExceptArray; /* 1 if ExceptionRange array was expanded and * exceptArrayPtr points in heap, else 0. */ -#endif LiteralEntry *literalArrayPtr; /* Points to start of LiteralEntry array. */ Tcl_Size literalArrayNext; /* Index of next free object array entry. */ @@ -339,9 +365,6 @@ typedef struct CompileEnv { * current range's array entry. */ Tcl_Size exceptArrayEnd; /* Index after the last ExceptionRange array * entry. */ -#if TCL_MAJOR_VERSION < 9 - int mallocedExceptArray; -#endif ExceptionAux *exceptAuxArrayPtr; /* Array of information used to restore the * state when processing BREAK/CONTINUE @@ -354,19 +377,14 @@ typedef struct CompileEnv { Tcl_Size cmdMapEnd; /* Index after last CmdLocation entry. */ int mallocedCmdMap; /* 1 if command map array was expanded and * cmdMapPtr points in the heap, else 0. */ -#if TCL_MAJOR_VERSION > 8 int mallocedAuxDataArray; /* 1 if aux data array was expanded and * auxDataArrayPtr points in heap else 0. */ -#endif AuxData *auxDataArrayPtr; /* Points to auxiliary data array start. */ Tcl_Size auxDataArrayNext; /* Next free compile aux data array index. * auxDataArrayNext is the number of aux data * items and (auxDataArrayNext-1) is index of * current aux data array entry. */ Tcl_Size auxDataArrayEnd; /* Index after last aux data array entry. */ -#if TCL_MAJOR_VERSION < 9 - int mallocedAuxDataArray; -#endif unsigned char staticCodeSpace[COMPILEENV_INIT_CODE_BYTES]; /* Initial storage for code. */ LiteralEntry staticLiteralSpace[COMPILEENV_INIT_NUM_OBJECTS]; @@ -383,7 +401,7 @@ typedef struct CompileEnv { /* TIP #280 */ ExtCmdLoc *extCmdMapPtr; /* Extended command location information for * 'info frame'. */ - Tcl_Size line; /* First line of the script, based on the + int line; /* First line of the script, based on the * invoking context, then the line of the * command currently compiled. */ int atCmdStart; /* Flag to say whether an INST_START_CMD @@ -402,28 +420,53 @@ typedef struct CompileEnv { } CompileEnv; /* - * The structure defining the bytecode instructions resulting from compiling a - * Tcl script. Note that this structure is variable length: a single heap - * object is allocated to hold the ByteCode structure immediately followed by - * the code bytes, the literal object array, the ExceptionRange array, the - * CmdLocation map, and the compilation AuxData array. + * Function to get the offset to the next instruction to be issued. + * More mnemonic than just putting the calculation in directly. */ +static inline Tcl_Size +CurrentOffset( + CompileEnv *envPtr) +{ + return envPtr->codeNext - envPtr->codeStart; +} /* - * A PRECOMPILED bytecode struct is one that was generated from a compiled - * image rather than implicitly compiled from source + * Information about what the current source line is. */ - -#define TCL_BYTECODE_PRECOMPILED 0x0001 +typedef struct LineInformation { + ExtCmdLoc *mapPtr; /* Extended command location information for + * 'info frame'. */ + Tcl_Size eclIndex; /* Current index into mapPtr->loc. */ +} LineInformation; /* - * When a bytecode is compiled, interp or namespace resolvers have not been - * applied yet: this is indicated by the TCL_BYTECODE_RESOLVE_VARS flag. + * The structure defining the bytecode instructions resulting from compiling a + * Tcl script. Note that this structure is variable length: a single heap + * object is allocated to hold the ByteCode structure immediately followed by + * the code bytes, the literal object array, the ExceptionRange array, the + * CmdLocation map, and the compilation AuxData array. */ -#define TCL_BYTECODE_RESOLVE_VARS 0x0002 +enum ByteCodeFlags { + /* + * A PRECOMPILED bytecode struct is one that was generated from a compiled + * image rather than implicitly compiled from source + */ + TCL_BYTECODE_PRECOMPILED = 0x0001, -#define TCL_BYTECODE_RECOMPILE 0x0004 + /* + * When a bytecode is compiled, interp or namespace resolvers have not been + * applied yet: this is indicated by the TCL_BYTECODE_RESOLVE_VARS flag. + */ + TCL_BYTECODE_RESOLVE_VARS = 0x0002, + + /* + * Used to note that a recompilation of the bytecode is believed necessary. + * The recompilation may generate the same bytecode sequence, but we can't + * prove that without doing it. + */ + TCL_BYTECODE_RECOMPILE = 0x0004 +}; typedef struct ByteCode { TclHandle interpHandle; /* Handle for interpreter containing the @@ -545,6 +588,34 @@ typedef struct ByteCode { } while (0) /* + * A special macro to allow an opcode in the TclInstruction enum to be marked + * as deprecated. The tricky bit is that we do *not* want the opcodes to be + * deprecated in the bytecode execution engine, disassembler or (for now) + * optimizer; if ALLOW_DEPRECATED_OPCODES is defined prior to including this + * file, DEPRECATED_OPCODE doesn't apply the deprecation marker. + * + * If REMOVE_DEPRECATED_OPCODES is defined, the opcodes are removed entirely + * and will be wholly unusable, even by precompiled bytecode. + */ + +#ifdef REMOVE_DEPRECATED_OPCODES +#define DEPRECATED_OPCODE(name) JOIN(INST_DEPRECATED_, __LINE__) +#elif defined(ALLOW_DEPRECATED_OPCODES) +#define DEPRECATED_OPCODE(name) \ + name +#elif defined(__STDC_VERSION__) && __STDC_VERSION__ >= 202311L +#define DEPRECATED_OPCODE(name) \ + name [[deprecated("use 4-byte operand version instead")]] +#elif defined(__GNUC__) || defined(__clang__) +/* Technically missing guards for some very old gcc/clang versions. */ +#define DEPRECATED_OPCODE(name) \ + name __attribute__((deprecated ("use 4-byte operand version instead"))) +#else +#define DEPRECATED_OPCODE(name) \ + name +#endif + +/* * Opcodes for the Tcl bytecode instructions. These must correspond to the * entries in the table of instruction descriptions, tclInstructionTable, in * tclCompile.c. Also, the order and number of the expression opcodes (e.g., @@ -555,53 +626,53 @@ typedef struct ByteCode { enum TclInstruction { /* Opcodes 0 to 9 */ INST_DONE = 0, - INST_PUSH1, - INST_PUSH4, + DEPRECATED_OPCODE(INST_PUSH1), + INST_PUSH = 2, INST_POP, INST_DUP, INST_STR_CONCAT1, - INST_INVOKE_STK1, - INST_INVOKE_STK4, + DEPRECATED_OPCODE(INST_INVOKE_STK1), + INST_INVOKE_STK = 7, INST_EVAL_STK, INST_EXPR_STK, /* Opcodes 10 to 23 */ - INST_LOAD_SCALAR1, - INST_LOAD_SCALAR4, - INST_LOAD_SCALAR_STK, - INST_LOAD_ARRAY1, - INST_LOAD_ARRAY4, + DEPRECATED_OPCODE(INST_LOAD_SCALAR1), + INST_LOAD_SCALAR = 11, + DEPRECATED_OPCODE(INST_LOAD_SCALAR_STK), // Not used + DEPRECATED_OPCODE(INST_LOAD_ARRAY1), + INST_LOAD_ARRAY = 14, INST_LOAD_ARRAY_STK, INST_LOAD_STK, - INST_STORE_SCALAR1, - INST_STORE_SCALAR4, - INST_STORE_SCALAR_STK, - INST_STORE_ARRAY1, - INST_STORE_ARRAY4, + DEPRECATED_OPCODE(INST_STORE_SCALAR1), + INST_STORE_SCALAR = 18, + DEPRECATED_OPCODE(INST_STORE_SCALAR_STK), // Not used + DEPRECATED_OPCODE(INST_STORE_ARRAY1), + INST_STORE_ARRAY = 21, INST_STORE_ARRAY_STK, INST_STORE_STK, /* Opcodes 24 to 33 */ - INST_INCR_SCALAR1, - INST_INCR_SCALAR_STK, - INST_INCR_ARRAY1, - INST_INCR_ARRAY_STK, + DEPRECATED_OPCODE(INST_INCR_SCALAR1), + INST_INCR_SCALAR_STK = 25, + DEPRECATED_OPCODE(INST_INCR_ARRAY1), + INST_INCR_ARRAY_STK = 27, INST_INCR_STK, - INST_INCR_SCALAR1_IMM, - INST_INCR_SCALAR_STK_IMM, - INST_INCR_ARRAY1_IMM, - INST_INCR_ARRAY_STK_IMM, + DEPRECATED_OPCODE(INST_INCR_SCALAR1_IMM), + INST_INCR_SCALAR_STK_IMM = 30, + DEPRECATED_OPCODE(INST_INCR_ARRAY1_IMM), + INST_INCR_ARRAY_STK_IMM = 32, INST_INCR_STK_IMM, /* Opcodes 34 to 39 */ - INST_JUMP1, - INST_JUMP4, - INST_JUMP_TRUE1, - INST_JUMP_TRUE4, - INST_JUMP_FALSE1, - INST_JUMP_FALSE4, - - /* Opcodes 42 to 64 */ + DEPRECATED_OPCODE(INST_JUMP1), + INST_JUMP = 35, + DEPRECATED_OPCODE(INST_JUMP_TRUE1), + INST_JUMP_TRUE = 37, + DEPRECATED_OPCODE(INST_JUMP_FALSE1), + INST_JUMP_FALSE = 39, + + /* Opcodes 42 to 60 */ INST_BITOR, INST_BITXOR, INST_BITAND, @@ -624,17 +695,17 @@ enum TclInstruction { INST_LNOT, INST_TRY_CVT_TO_NUMERIC, - /* Opcodes 65 to 66 */ + /* Opcodes 61 to 62 */ INST_BREAK, INST_CONTINUE, - /* Opcodes 69 to 72 */ - INST_BEGIN_CATCH4, + /* Opcodes 63 to 66 */ + INST_BEGIN_CATCH, INST_END_CATCH, INST_PUSH_RESULT, INST_PUSH_RETURN_CODE, - /* Opcodes 73 to 78 */ + /* Opcodes 67 to 72 */ INST_STR_EQ, INST_STR_NEQ, INST_STR_CMP, @@ -642,24 +713,24 @@ enum TclInstruction { INST_STR_INDEX, INST_STR_MATCH, - /* Opcodes 79 to 81 */ + /* Opcodes 73 to 75 */ INST_LIST, INST_LIST_INDEX, INST_LIST_LENGTH, - /* Opcodes 82 to 87 */ - INST_APPEND_SCALAR1, - INST_APPEND_SCALAR4, - INST_APPEND_ARRAY1, - INST_APPEND_ARRAY4, + /* Opcodes 76 to 81 */ + DEPRECATED_OPCODE(INST_APPEND_SCALAR1), + INST_APPEND_SCALAR = 77, + DEPRECATED_OPCODE(INST_APPEND_ARRAY1), + INST_APPEND_ARRAY = 79, INST_APPEND_ARRAY_STK, INST_APPEND_STK, - /* Opcodes 88 to 93 */ - INST_LAPPEND_SCALAR1, - INST_LAPPEND_SCALAR4, - INST_LAPPEND_ARRAY1, - INST_LAPPEND_ARRAY4, + /* Opcodes 82 to 87 */ + DEPRECATED_OPCODE(INST_LAPPEND_SCALAR1), + INST_LAPPEND_SCALAR = 83, + DEPRECATED_OPCODE(INST_LAPPEND_ARRAY1), + INST_LAPPEND_ARRAY = 85, INST_LAPPEND_ARRAY_STK, INST_LAPPEND_STK, @@ -742,10 +813,10 @@ enum TclInstruction { /* For [subst] compilation */ INST_NOP, - INST_RETURN_CODE_BRANCH, + DEPRECATED_OPCODE(INST_RETURN_CODE_BRANCH), /* For [unset] compilation */ - INST_UNSET_SCALAR, + INST_UNSET_SCALAR = 127, INST_UNSET_ARRAY, INST_UNSET_ARRAY_STK, INST_UNSET_STK, @@ -767,10 +838,10 @@ enum TclInstruction { /* For operations to do with coroutines and other NRE-manipulators */ INST_YIELD, INST_COROUTINE_NAME, - INST_TAILCALL, + DEPRECATED_OPCODE(INST_TAILCALL1), /* For compilation of basic information operations */ - INST_NS_CURRENT, + INST_NS_CURRENT = 144, INST_INFO_LEVEL_NUM, INST_INFO_LEVEL_ARGS, INST_RESOLVE_COMMAND, @@ -813,10 +884,10 @@ enum TclInstruction { INST_ORIGIN_COMMAND, - INST_TCLOO_NEXT, - INST_TCLOO_NEXT_CLASS, + DEPRECATED_OPCODE(INST_TCLOO_NEXT1), + DEPRECATED_OPCODE(INST_TCLOO_NEXT_CLASS1), - INST_YIELD_TO_INVOKE, + INST_YIELD_TO_INVOKE = 174, INST_NUM_TYPE, INST_TRY_CVT_TO_BOOLEAN, @@ -837,12 +908,35 @@ enum TclInstruction { INST_STR_LE, INST_STR_GE, - INST_LREPLACE4, + INST_LREPLACE, /* TIP 667: const */ INST_CONST_IMM, INST_CONST_STK, + /* Updated compilations with fewer arg size constraints for 9.1 */ + INST_INCR_SCALAR, + INST_INCR_ARRAY, + INST_INCR_SCALAR_IMM, + INST_INCR_ARRAY_IMM, + INST_TAILCALL, + INST_TCLOO_NEXT, + INST_TCLOO_NEXT_CLASS, + + /* Really new opcodes for 9.1 */ + INST_SWAP, + INST_ERROR_PREFIX_EQ, + INST_TCLOO_ID, + INST_DICT_PUT, + INST_DICT_REMOVE, + INST_IS_EMPTY, + INST_JUMP_TABLE_NUM, + INST_TAILCALL_LIST, + INST_TCLOO_NEXT_LIST, + INST_TCLOO_NEXT_CLASS_LIST, + INST_ARITH_SERIES, + INST_UPLEVEL, + /* The last opcode */ LAST_INST_OPCODE }; @@ -878,7 +972,10 @@ typedef enum InstOperandType { * literals. */ OPERAND_LIT4, /* Four byte unsigned index into table of * literals. */ - OPERAND_SCLS1 /* Index into tclStringClassTable. */ + OPERAND_SCLS1, /* Index into tclStringClassTable. */ + OPERAND_UNSF1, /* Flags for [unset] */ + OPERAND_CLK1, /* Index into [clock] types. */ + OPERAND_LRPL1 /* Combination of TCL_LREPLACE_* flags. */ } InstOperandType; typedef struct InstructionDesc { @@ -987,7 +1084,7 @@ typedef struct JumpFixupArray { typedef struct ForeachVarList { Tcl_Size numVars; /* The number of variables in the list. */ - Tcl_Size varIndexes[TCLFLEXARRAY]; + Tcl_LVTIndex varIndexes[TCLFLEXARRAY]; /* An array of the indexes ("slot numbers") * for each variable in the procedure's array * of local variables. Only scalar variables @@ -1006,9 +1103,9 @@ typedef struct ForeachVarList { typedef struct ForeachInfo { Tcl_Size numLists; /* The number of both the variable and value * lists of the foreach command. */ - Tcl_Size firstValueTemp; /* Index of the first temp var in a proc frame + Tcl_LVTIndex firstValueTemp;/* Index of the first temp var in a proc frame * used to point to a value list. */ - Tcl_Size loopCtTemp; /* Index of temp var in a proc frame holding + Tcl_LVTIndex loopCtTemp; /* Index of temp var in a proc frame holding * the loop's iteration count. Used to * determine next value list element to assign * each loop var. */ @@ -1021,7 +1118,7 @@ typedef struct ForeachInfo { } ForeachInfo; /* - * Structure used to hold information about a switch command that is needed + * Structures used to hold information about a switch command that is needed * during program execution. These structures are stored in CompileEnv and * ByteCode structures as auxiliary data. */ @@ -1034,7 +1131,71 @@ typedef struct JumptableInfo { MODULE_SCOPE const AuxDataType tclJumptableInfoType; #define JUMPTABLEINFO(envPtr, index) \ - ((JumptableInfo*)((envPtr)->auxDataArrayPtr[TclGetUInt4AtPtr(index)].clientData)) + ((JumptableInfo *) TclFetchAuxData((envPtr), TclGetUInt4AtPtr(index))) + +static inline JumptableInfo * +AllocJumptable(void) +{ + JumptableInfo *jtPtr = (JumptableInfo *) Tcl_Alloc(sizeof(JumptableInfo)); + Tcl_InitHashTable(&jtPtr->hashTable, TCL_STRING_KEYS); + return jtPtr; +} + +static inline int +CreateJumptableEntry( + JumptableInfo *jtPtr, + const char *keyPtr, + Tcl_Size offset) +{ + int isNew; + Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(&jtPtr->hashTable, keyPtr, + &isNew); + if (isNew) { + Tcl_SetHashValue(hPtr, INT2PTR(offset)); + } + return isNew; +} + +#define CreateJumptableEntryToHere(jtPtr, key, baseOffset) \ + CreateJumptableEntry((jtPtr), (key), CurrentOffset(envPtr) - (baseOffset)) + +typedef struct JumptableNumInfo { + Tcl_HashTable hashTable; /* Hash that maps Tcl_WideInt to signed ints + * (PC offsets). */ +} JumptableNumInfo; + +MODULE_SCOPE const AuxDataType tclJumptableNumericInfoType; + +#define JUMPTABLENUMINFO(envPtr, index) \ + ((JumptableNumInfo *) TclFetchAuxData((envPtr), TclGetUInt4AtPtr(index))) + +static inline JumptableNumInfo * +AllocJumptableNum(void) +{ + JumptableNumInfo *jtnPtr = (JumptableNumInfo *) + Tcl_Alloc(sizeof(JumptableNumInfo)); + Tcl_InitHashTable(&jtnPtr->hashTable, TCL_ONE_WORD_KEYS); + return jtnPtr; +} + +static inline int +CreateJumptableNumEntry( + JumptableNumInfo *jtnPtr, + Tcl_Size key, + Tcl_Size offset) +{ + int isNew; + Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(&jtnPtr->hashTable, INT2PTR(key), + &isNew); + if (isNew) { + Tcl_SetHashValue(hPtr, INT2PTR(offset)); + } + return isNew; +} + +#define CreateJumptableNumEntryToHere(jtnPtr, key, baseOffset) \ + CreateJumptableNumEntry((jtnPtr), (key), \ + CurrentOffset(envPtr) - (baseOffset)) /* * Structure used to hold information about a [dict update] command that is @@ -1042,7 +1203,7 @@ MODULE_SCOPE const AuxDataType tclJumptableInfoType; * and ByteCode structures as auxiliary data. */ -typedef struct { +typedef struct DictUpdateInfo { Tcl_Size length; /* Size of array */ Tcl_Size varIndices[TCLFLEXARRAY]; /* Array of variable indices to manage when @@ -1057,10 +1218,10 @@ typedef struct { * ClientData type used by the math operator commands. */ -typedef struct { +typedef struct TclOpCmdClientData { const char *op; /* Do not call it 'operator': C++ reserved */ const char *expected; - union { + union OperatorParameter { int numArgs; int identity; } i; @@ -1072,7 +1233,6 @@ typedef struct { *---------------------------------------------------------------- */ -#if TCL_MAJOR_VERSION > 8 MODULE_SCOPE Tcl_ObjCmdProc TclNRInterpCoroutine; /* @@ -1082,7 +1242,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRInterpCoroutine; */ MODULE_SCOPE ByteCode * TclCompileObj(Tcl_Interp *interp, Tcl_Obj *objPtr, - const CmdFrame *invoker, int word); + const CmdFrame *invoker, Tcl_Size word); /* *---------------------------------------------------------------- @@ -1096,6 +1256,8 @@ MODULE_SCOPE int TclAttemptCompileProc(Tcl_Interp *interp, CompileEnv *envPtr); MODULE_SCOPE void TclCleanupStackForBreakContinue(CompileEnv *envPtr, ExceptionAux *auxPtr); +MODULE_SCOPE void TclClearFailedCompile(CompileEnv *envPtr, + LineInformation *lineInfoPtr); MODULE_SCOPE void TclCompileCmdWord(Tcl_Interp *interp, Tcl_Token *tokenPtr, Tcl_Size count, CompileEnv *envPtr); @@ -1117,9 +1279,9 @@ MODULE_SCOPE void TclCompileTokens(Tcl_Interp *interp, CompileEnv *envPtr); MODULE_SCOPE void TclCompileVarSubst(Tcl_Interp *interp, Tcl_Token *tokenPtr, CompileEnv *envPtr); -MODULE_SCOPE Tcl_Size TclCreateAuxData(void *clientData, +MODULE_SCOPE Tcl_AuxDataRef TclCreateAuxData(void *clientData, const AuxDataType *typePtr, CompileEnv *envPtr); -MODULE_SCOPE Tcl_Size TclCreateExceptRange(ExceptionRangeType type, +MODULE_SCOPE Tcl_ExceptionRange TclCreateExceptRange(ExceptionRangeType type, CompileEnv *envPtr); MODULE_SCOPE ExecEnv * TclCreateExecEnv(Tcl_Interp *interp, size_t size); MODULE_SCOPE Tcl_Obj * TclCreateLiteral(Interp *iPtr, const char *bytes, @@ -1138,11 +1300,10 @@ MODULE_SCOPE void TclExpandJumpFixupArray(JumpFixupArray *fixupArrayPtr); MODULE_SCOPE int TclNRExecuteByteCode(Tcl_Interp *interp, ByteCode *codePtr); MODULE_SCOPE Tcl_Obj * TclFetchLiteral(CompileEnv *envPtr, Tcl_Size index); -MODULE_SCOPE Tcl_Size TclFindCompiledLocal(const char *name, Tcl_Size nameChars, +MODULE_SCOPE Tcl_LVTIndex TclFindCompiledLocal(const char *name, Tcl_Size nameChars, int create, CompileEnv *envPtr); -MODULE_SCOPE int TclFixupForwardJump(CompileEnv *envPtr, - JumpFixup *jumpFixupPtr, int jumpDist, - int distThreshold); +MODULE_SCOPE void TclFixupForwardJump(CompileEnv *envPtr, + JumpFixup *jumpFixupPtr, Tcl_Size jumpDist); MODULE_SCOPE void TclFreeCompileEnv(CompileEnv *envPtr); MODULE_SCOPE void TclFreeJumpFixupArray(JumpFixupArray *fixupArrayPtr); MODULE_SCOPE int TclGetIndexFromToken(Tcl_Token *tokenPtr, @@ -1152,24 +1313,25 @@ MODULE_SCOPE ByteCode * TclInitByteCodeObj(Tcl_Obj *objPtr, const Tcl_ObjType *typePtr, CompileEnv *envPtr); MODULE_SCOPE void TclInitCompileEnv(Tcl_Interp *interp, CompileEnv *envPtr, const char *string, - size_t numBytes, const CmdFrame *invoker, int word); + size_t numBytes, const CmdFrame *invoker, Tcl_Size word); MODULE_SCOPE void TclInitJumpFixupArray(JumpFixupArray *fixupArrayPtr); MODULE_SCOPE void TclInitLiteralTable(LiteralTable *tablePtr); MODULE_SCOPE ExceptionRange *TclGetInnermostExceptionRange(CompileEnv *envPtr, int returnCode, ExceptionAux **auxPtrPtr); +MODULE_SCOPE int TclIsEmptyToken(const Tcl_Token *tokenPtr); MODULE_SCOPE void TclAddLoopBreakFixup(CompileEnv *envPtr, ExceptionAux *auxPtr); MODULE_SCOPE void TclAddLoopContinueFixup(CompileEnv *envPtr, ExceptionAux *auxPtr); MODULE_SCOPE void TclFinalizeLoopExceptionRange(CompileEnv *envPtr, - int range); + Tcl_Size range); #ifdef TCL_COMPILE_STATS MODULE_SCOPE char * TclLiteralStats(LiteralTable *tablePtr); MODULE_SCOPE int TclLog2(long long value); #endif -MODULE_SCOPE size_t TclLocalScalar(const char *bytes, size_t numBytes, +MODULE_SCOPE Tcl_LVTIndex TclLocalScalar(const char *bytes, size_t numBytes, CompileEnv *envPtr); -MODULE_SCOPE size_t TclLocalScalarFromToken(Tcl_Token *tokenPtr, +MODULE_SCOPE Tcl_LVTIndex TclLocalScalarFromToken(Tcl_Token *tokenPtr, CompileEnv *envPtr); MODULE_SCOPE void TclOptimizeBytecode(void *envPtr); #ifdef TCL_COMPILE_DEBUG @@ -1185,9 +1347,11 @@ MODULE_SCOPE void TclPrintSource(FILE *outFile, const char *string, Tcl_Size maxChars); MODULE_SCOPE void TclPushVarName(Tcl_Interp *interp, Tcl_Token *varTokenPtr, CompileEnv *envPtr, - int flags, int *localIndexPtr, + int flags, Tcl_LVTIndex *localIndexPtr, int *isScalarPtr); MODULE_SCOPE void TclPreserveByteCode(ByteCode *codePtr); +MODULE_SCOPE int TclRegisterLiteralObj(CompileEnv *envPtr, + Tcl_Obj *objPtr, int flags); MODULE_SCOPE void TclReleaseByteCode(ByteCode *codePtr); MODULE_SCOPE void TclReleaseLiteral(Tcl_Interp *interp, Tcl_Obj *objPtr); MODULE_SCOPE void TclInvalidateCmdLiteral(Tcl_Interp *interp, @@ -1212,7 +1376,6 @@ MODULE_SCOPE Tcl_Obj * TclNewInstNameObj(unsigned char inst); MODULE_SCOPE int TclPushProcCallFrame(void *clientData, Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[], int isLambda); -#endif /* TCL_MAJOR_VERSION > 8 */ /* *---------------------------------------------------------------- @@ -1221,18 +1384,29 @@ MODULE_SCOPE int TclPushProcCallFrame(void *clientData, *---------------------------------------------------------------- */ +// Point at which we issue a LIST_CONCAT anyway when doing an expansion sequence +#define LIST_CONCAT_THRESHOLD (1 << 15) + /* * Simplified form to access AuxData. * - * void *TclFetchAuxData(CompileEng *envPtr, int index); + * void *TclFetchAuxData(CompileEng *envPtr, Tcl_AuxDataRef index); */ #define TclFetchAuxData(envPtr, index) \ (envPtr)->auxDataArrayPtr[(index)].clientData -#define LITERAL_ON_HEAP 0x01 -#define LITERAL_CMD_NAME 0x02 -#define LITERAL_UNSHARED 0x04 +// Flags for TclRegisterLiteral() +enum LiteralFlags { + LITERAL_ON_HEAP = 0x01, /* The caller of TclRegisterLiteral already + * malloc'd bytes and ownership is passed to + * the literal store. */ + LITERAL_CMD_NAME = 0x02, /* The literal should not be shared across + * namespaces. */ + LITERAL_UNSHARED = 0x04 /* The literal should not be shared with any + * other usage, even if they're the same string + * in the same stack frame. */ +}; /* * Adjust the stack requirements. Manually used in cases where the stack @@ -1241,11 +1415,11 @@ MODULE_SCOPE int TclPushProcCallFrame(void *clientData, */ static inline void TclAdjustStackDepth( - int delta, + Tcl_Size delta, CompileEnv *envPtr) { if (delta < 0) { - if ((int) envPtr->maxStackDepth < (int) envPtr->currStackDepth) { + if (envPtr->maxStackDepth < envPtr->currStackDepth) { envPtr->maxStackDepth = envPtr->currStackDepth; } } @@ -1276,7 +1450,7 @@ TclCheckStackDepth( /* * Update the stack requirements based on the instruction definition. It is - * called by the macros TclEmitOpCode, TclEmitInst1 and TclEmitInst4. + * called by the functions TclEmitOpCode, TclEmitInst1, TclEmitInst4, et al. * Remark that the very last instruction of a bytecode always reduces the * stack level: INST_DONE or INST_POP, so that the maxStackdepth is always * updated. @@ -1284,155 +1458,278 @@ TclCheckStackDepth( static inline void TclUpdateStackReqs( unsigned char op, - int i, + Tcl_Size i, CompileEnv *envPtr) { - int delta = tclInstructionTable[op].stackEffect; + Tcl_Size delta = tclInstructionTable[op].stackEffect; if (delta) { if (delta == INT_MIN) { + if (i > INT_MAX || i < INT_MIN+2) { + Tcl_Panic("%s: stack effect too big", "TclUpdateStackReqs"); + } delta = 1 - i; } TclAdjustStackDepth(delta, envPtr); } + + /* + * Apply stack depth corrections. + * These instructions are encoded wrongly because they're cases the + * original instruction table design wasn't designed to handle. + */ + switch (op) { + case INST_DICT_GET: + case INST_DICT_SET: + case INST_DICT_EXISTS: + case INST_INVOKE_REPLACE: + TclAdjustStackDepth(-1, envPtr); + break; + case INST_DICT_GET_DEF: + TclAdjustStackDepth(-2, envPtr); + break; + default: + /* Do nothing special */ + break; + } } /* - * Macros used to update the flag that indicates if we are at the start of a + * Function used to update the flag that indicates if we are at the start of a * command, based on whether the opcode is INST_START_COMMAND. - * - * void TclUpdateAtCmdStart(unsigned char op, CompileEnv *envPtr); */ -#define TclUpdateAtCmdStart(op, envPtr) \ - if ((envPtr)->atCmdStart < 2) { \ - (envPtr)->atCmdStart = ((op) == INST_START_CMD ? 1 : 0); \ +static inline void +TclUpdateAtCmdStart( + unsigned char op, + CompileEnv *envPtr) +{ + if (envPtr->atCmdStart < 2) { + envPtr->atCmdStart = (op == INST_START_CMD ? 1 : 0); } +} /* - * Macro to emit an opcode byte into a CompileEnv's code array. The ANSI C - * "prototype" for this macro is: - * - * void TclEmitOpcode(unsigned char op, CompileEnv *envPtr); + * Function to emit an opcode byte into a CompileEnv's code array. */ -#define TclEmitOpcode(op, envPtr) \ - do { \ - if ((envPtr)->codeNext == (envPtr)->codeEnd) { \ - TclExpandCodeArray(envPtr); \ - } \ - *(envPtr)->codeNext++ = (unsigned char) (op); \ - TclUpdateAtCmdStart(op, envPtr); \ - TclUpdateStackReqs(op, 0, envPtr); \ - } while (0) +static inline void +TclEmitOpcode( + unsigned char op, + CompileEnv *envPtr) +{ + if (envPtr->codeNext == envPtr->codeEnd) { + TclExpandCodeArray(envPtr); + } + + *envPtr->codeNext++ = UCHAR(op); + + TclUpdateAtCmdStart(op, envPtr); + TclUpdateStackReqs(op, 0, envPtr); +} /* - * Macros to emit an integer operand. The ANSI C "prototype" for these macros - * are: - * - * void TclEmitInt1(int i, CompileEnv *envPtr); - * void TclEmitInt4(int i, CompileEnv *envPtr); + * Functions to emit an integer operand. The macro wrappers allow any C + * integral type to be passed. */ +static inline void +TclEmitInt1Impl( + unsigned i, + CompileEnv *envPtr) +{ + if (envPtr->codeNext == envPtr->codeEnd) { + TclExpandCodeArray(envPtr); + } + + *envPtr->codeNext++ = UCHAR(i); +} #define TclEmitInt1(i, envPtr) \ - do { \ - if ((envPtr)->codeNext == (envPtr)->codeEnd) { \ - TclExpandCodeArray(envPtr); \ - } \ - *(envPtr)->codeNext++ = (unsigned char) ((unsigned int) (i)); \ - } while (0) + TclEmitInt1Impl((unsigned)(i), (envPtr)) + +static inline void +TclEmitInt4Impl( + unsigned i, + CompileEnv *envPtr) +{ + if (envPtr->codeNext + 4 > envPtr->codeEnd) { + TclExpandCodeArray(envPtr); + } + *envPtr->codeNext++ = UCHAR(i >> 24); + *envPtr->codeNext++ = UCHAR(i >> 16); + *envPtr->codeNext++ = UCHAR(i >> 8); + *envPtr->codeNext++ = UCHAR(i ); +} #define TclEmitInt4(i, envPtr) \ - do { \ - if (((envPtr)->codeNext + 4) > (envPtr)->codeEnd) { \ - TclExpandCodeArray(envPtr); \ - } \ - *(envPtr)->codeNext++ = \ - (unsigned char) ((unsigned int) (i) >> 24); \ - *(envPtr)->codeNext++ = \ - (unsigned char) ((unsigned int) (i) >> 16); \ - *(envPtr)->codeNext++ = \ - (unsigned char) ((unsigned int) (i) >> 8); \ - *(envPtr)->codeNext++ = \ - (unsigned char) ((unsigned int) (i) ); \ - } while (0) + TclEmitInt4Impl((unsigned)(i), (envPtr)) /* - * Macros to emit an instruction with signed or unsigned integer operands. + * Functions to emit an instruction with signed or unsigned integer operands. * Four byte integers are stored in "big-endian" order with the high order - * byte stored at the lowest address. The ANSI C "prototypes" for these macros - * are: - * - * void TclEmitInstInt1(unsigned char op, int i, CompileEnv *envPtr); - * void TclEmitInstInt4(unsigned char op, int i, CompileEnv *envPtr); + * byte stored at the lowest address. The macro wrappers allow any C + * integral type to be passed. */ +static inline void +TclEmitInstInt1Impl( + unsigned char op, + unsigned i, + CompileEnv *envPtr) +{ + if (envPtr->codeNext + 2 > envPtr->codeEnd) { + TclExpandCodeArray(envPtr); + } + + *envPtr->codeNext++ = UCHAR(op); + *envPtr->codeNext++ = UCHAR(i); + + TclUpdateAtCmdStart(op, envPtr); + // Emit 1-byte argument + TclUpdateStackReqs(op, i, envPtr); +} #define TclEmitInstInt1(op, i, envPtr) \ - do { \ - if (((envPtr)->codeNext + 2) > (envPtr)->codeEnd) { \ - TclExpandCodeArray(envPtr); \ - } \ - *(envPtr)->codeNext++ = (unsigned char) (op); \ - *(envPtr)->codeNext++ = (unsigned char) ((unsigned int) (i)); \ - TclUpdateAtCmdStart(op, envPtr); \ - TclUpdateStackReqs(op, i, envPtr); \ - } while (0) + TclEmitInstInt1Impl((op), (unsigned)(i), (envPtr)) +static inline void +TclEmitInstInt4Impl( + unsigned char op, + unsigned i, + CompileEnv *envPtr) +{ + if (envPtr->codeNext + 5 > envPtr->codeEnd) { + TclExpandCodeArray(envPtr); + } + + *envPtr->codeNext++ = UCHAR(op); + // Emit 4-byte argument + *envPtr->codeNext++ = UCHAR(i >> 24); + *envPtr->codeNext++ = UCHAR(i >> 16); + *envPtr->codeNext++ = UCHAR(i >> 8); + *envPtr->codeNext++ = UCHAR(i ); + + TclUpdateAtCmdStart(op, envPtr); + TclUpdateStackReqs(op, i, envPtr); +} #define TclEmitInstInt4(op, i, envPtr) \ - do { \ - if (((envPtr)->codeNext + 5) > (envPtr)->codeEnd) { \ - TclExpandCodeArray(envPtr); \ - } \ - *(envPtr)->codeNext++ = (unsigned char) (op); \ - *(envPtr)->codeNext++ = \ - (unsigned char) ((unsigned int) (i) >> 24); \ - *(envPtr)->codeNext++ = \ - (unsigned char) ((unsigned int) (i) >> 16); \ - *(envPtr)->codeNext++ = \ - (unsigned char) ((unsigned int) (i) >> 8); \ - *(envPtr)->codeNext++ = \ - (unsigned char) ((unsigned int) (i) ); \ - TclUpdateAtCmdStart(op, envPtr); \ - TclUpdateStackReqs(op, i, envPtr); \ - } while (0) + TclEmitInstInt4Impl((op), (unsigned)(i), (envPtr)) + +static inline void +TclEmitInstInt14( + unsigned char op, + unsigned i, + unsigned j, + CompileEnv *envPtr) +{ + if (envPtr->codeNext + 6 > envPtr->codeEnd) { + TclExpandCodeArray(envPtr); + } + + *envPtr->codeNext++ = UCHAR(op); + // Emit 1-byte argument + *envPtr->codeNext++ = UCHAR(i ); + // Emit 4-byte argument + *envPtr->codeNext++ = UCHAR(j >> 24); + *envPtr->codeNext++ = UCHAR(j >> 16); + *envPtr->codeNext++ = UCHAR(j >> 8); + *envPtr->codeNext++ = UCHAR(j ); + + TclUpdateAtCmdStart(op, envPtr); + TclUpdateStackReqs(op, i, envPtr); +} + +static inline void +TclEmitInstInt41( + unsigned char op, + unsigned i, + unsigned j, + CompileEnv *envPtr) +{ + if (envPtr->codeNext + 6 > envPtr->codeEnd) { + TclExpandCodeArray(envPtr); + } + + *envPtr->codeNext++ = UCHAR(op); + // Emit 4-byte argument + *envPtr->codeNext++ = UCHAR(i >> 24); + *envPtr->codeNext++ = UCHAR(i >> 16); + *envPtr->codeNext++ = UCHAR(i >> 8); + *envPtr->codeNext++ = UCHAR(i ); + // Emit 1-byte argument + *envPtr->codeNext++ = UCHAR(j ); + + TclUpdateAtCmdStart(op, envPtr); + TclUpdateStackReqs(op, i, envPtr); +} + +static inline void +TclEmitInstInt44( + unsigned char op, + unsigned i, + unsigned j, + CompileEnv *envPtr) +{ + if (envPtr->codeNext + 9 > envPtr->codeEnd) { + TclExpandCodeArray(envPtr); + } + + *envPtr->codeNext++ = UCHAR(op); + // Emit 4-byte argument + *envPtr->codeNext++ = UCHAR(i >> 24); + *envPtr->codeNext++ = UCHAR(i >> 16); + *envPtr->codeNext++ = UCHAR(i >> 8); + *envPtr->codeNext++ = UCHAR(i ); + // Emit 4-byte argument + *envPtr->codeNext++ = UCHAR(j >> 24); + *envPtr->codeNext++ = UCHAR(j >> 16); + *envPtr->codeNext++ = UCHAR(j >> 8); + *envPtr->codeNext++ = UCHAR(j ); + + TclUpdateAtCmdStart(op, envPtr); + TclUpdateStackReqs(op, i, envPtr); +} /* - * Macro to push a Tcl object onto the Tcl evaluation stack. It emits the - * object's one or four byte array index into the CompileEnv's code array. - * These support, respectively, a maximum of 256 (2**8) and 2**32 objects in a - * CompileEnv. The ANSI C "prototype" for this macro is: - * - * void TclEmitPush(int objIndex, CompileEnv *envPtr); + * Function to push a Tcl object onto the Tcl evaluation stack. It emits the + * object's four byte array index into the CompileEnv's code array. + * This supports a maximum of 2**32 objects in a CompileEnv. */ -#define TclEmitPush(objIndex, envPtr) \ - do { \ - int _objIndexCopy = (objIndex); \ - if (_objIndexCopy <= 255) { \ - TclEmitInstInt1(INST_PUSH1, _objIndexCopy, (envPtr)); \ - } else { \ - TclEmitInstInt4(INST_PUSH4, _objIndexCopy, (envPtr)); \ - } \ - } while (0) +static inline int +TclEmitPush( + int objIndex, + CompileEnv *envPtr) +{ + TclEmitInstInt4(INST_PUSH, objIndex, envPtr); + return objIndex; +} /* * Macros to update a (signed or unsigned) integer starting at a pointer. The - * two variants depend on the number of bytes. The ANSI C "prototypes" for - * these macros are: - * - * void TclStoreInt1AtPtr(int i, unsigned char *p); - * void TclStoreInt4AtPtr(int i, unsigned char *p); + * two variants depend on the number of bytes. */ +static inline void +TclStoreInt1AtPtrImpl( + unsigned i, + unsigned char *p) +{ + p[0] = UCHAR(i); +} #define TclStoreInt1AtPtr(i, p) \ - *(p) = (unsigned char) ((unsigned int) (i)) + TclStoreInt1AtPtrImpl((unsigned)(i), (p)) +static inline void +TclStoreInt4AtPtrImpl( + unsigned i, + unsigned char *p) +{ + p[0] = UCHAR(i >> 24); + p[1] = UCHAR(i >> 16); + p[2] = UCHAR(i >> 8); + p[3] = UCHAR(i ); +} #define TclStoreInt4AtPtr(i, p) \ - do { \ - *(p) = (unsigned char) ((unsigned int) (i) >> 24); \ - *(p+1) = (unsigned char) ((unsigned int) (i) >> 16); \ - *(p+2) = (unsigned char) ((unsigned int) (i) >> 8); \ - *(p+3) = (unsigned char) ((unsigned int) (i) ); \ - } while (0) + TclStoreInt4AtPtrImpl((unsigned)(i), (p)) /* * Macros to update instructions at a particular pc with a new op code and a @@ -1445,29 +1742,29 @@ TclUpdateStackReqs( #define TclUpdateInstInt1AtPc(op, i, pc) \ do { \ - *(pc) = (unsigned char) (op); \ + *(pc) = UCHAR(op); \ TclStoreInt1AtPtr((i), ((pc)+1)); \ } while (0) #define TclUpdateInstInt4AtPc(op, i, pc) \ do { \ - *(pc) = (unsigned char) (op); \ + *(pc) = UCHAR(op); \ TclStoreInt4AtPtr((i), ((pc)+1)); \ } while (0) /* - * Macro to fix up a forward jump to point to the current code-generation - * position in the bytecode being created (the most common case). The ANSI C - * "prototypes" for this macro is: - * - * int TclFixupForwardJumpToHere(CompileEnv *envPtr, JumpFixup *fixupPtr, - * int threshold); + * Inline func to fix up a forward jump to point to the current code-generation + * position in the bytecode being created (the most common case). */ -#define TclFixupForwardJumpToHere(envPtr, fixupPtr, threshold) \ - TclFixupForwardJump((envPtr), (fixupPtr), \ - (envPtr)->codeNext-(envPtr)->codeStart-(int)(fixupPtr)->codeOffset, \ - (threshold)) +static inline void +TclFixupForwardJumpToHere( + CompileEnv *envPtr, + JumpFixup *fixupPtr) +{ + TclFixupForwardJump(envPtr, fixupPtr, + CurrentOffset(envPtr) - (int) fixupPtr->codeOffset); +} /* * Macros to get a signed integer (GET_INT{1,2}) or an unsigned int @@ -1482,35 +1779,52 @@ TclUpdateStackReqs( */ /* - * The TclGetInt1AtPtr macro is tricky because we want to do sign extension on - * the 1-byte value. Unfortunately the "char" type isn't signed on all + * The TclGetInt1AtPtr function is tricky because we want to do sign extension + * on the 1-byte value. Unfortunately the "char" type isn't signed on all * platforms so sign-extension doesn't always happen automatically. Sometimes * we can explicitly declare the pointer to be signed, but other times we have * to explicitly sign-extend the value in software. */ +static inline int +TclGetInt1AtPtr( + const unsigned char *p) +{ #ifndef __CHAR_UNSIGNED__ -# define TclGetInt1AtPtr(p) ((int) *((char *) p)) + return (int) *((char *) p); #elif defined(HAVE_SIGNED_CHAR) -# define TclGetInt1AtPtr(p) ((int) *((signed char *) p)) + return (int) *((signed char *) p); #else -# define TclGetInt1AtPtr(p) \ - ((int) ((*((char *) p)) | ((*(p) & 0200) ? (-256) : 0))) + return (int) ((*((char *) p)) | ((*(p) & 0200) ? (-256) : 0)); #endif +} + +static inline unsigned int +TclGetUInt1AtPtr( + const unsigned char *p) +{ + return (unsigned) *p; +} -#define TclGetInt4AtPtr(p) \ - ((int) ((TclGetUInt1AtPtr(p) << 24) | \ - (*((p)+1) << 16) | \ - (*((p)+2) << 8) | \ - (*((p)+3)))) +static inline int +TclGetInt4AtPtr( + const unsigned char *p) +{ + return (int) ( + (TclGetUInt1AtPtr(p) << 24) | + (p[1] << 16) | + (p[2] << 8) | + (p[3] )); +} -#define TclGetUInt1AtPtr(p) \ - ((unsigned int) *(p)) -#define TclGetUInt4AtPtr(p) \ - ((unsigned int) ((*(p) << 24) | \ - (*((p)+1) << 16) | \ - (*((p)+2) << 8) | \ - (*((p)+3)))) +static inline unsigned +TclGetUInt4AtPtr(const unsigned char *p) { + return (unsigned) ( + (p[0] << 24) | + (p[1] << 16) | + (p[2] << 8) | + (p[3] )); +} /* * Macros used to compute the minimum and maximum of two values. The ANSI C @@ -1520,20 +1834,8 @@ TclUpdateStackReqs( * size_t TclMax(size_t i, size_t j); */ -#define TclMin(i, j) ((((size_t) i) + 1 < ((size_t) j) + 1 )? (i) : (j)) -#define TclMax(i, j) ((((size_t) i) + 1 > ((size_t) j) + 1 )? (i) : (j)) - -/* - * Convenience macros for use when compiling bodies of commands. The ANSI C - * "prototype" for these macros are: - * - * static void BODY(Tcl_Token *tokenPtr, int word); - */ - -#define BODY(tokenPtr, word) \ - SetLineInformation((word)); \ - TclCompileCmdWord(interp, (tokenPtr)+1, (tokenPtr)->numComponents, \ - envPtr) +#define TclMin(i, j) ((((size_t) i) + 1 < ((size_t) j) + 1) ? (i) : (j)) +#define TclMax(i, j) ((((size_t) i) + 1 > ((size_t) j) + 1) ? (i) : (j)) /* * Convenience macro for use when compiling tokens to be pushed. The ANSI C @@ -1546,40 +1848,28 @@ TclUpdateStackReqs( #define CompileTokens(envPtr, tokenPtr, interp) \ TclCompileTokens((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \ (envPtr)); + /* - * Convenience macros for use when pushing literals. The ANSI C "prototype" for - * these macros are: + * Convenience macro for use when pushing literals, returning the ID of the + * literal. The ANSI C "prototype" for the macro is: * - * static void PushLiteral(CompileEnv *envPtr, + * static int PushLiteral(CompileEnv *envPtr, * const char *string, Tcl_Size length); - * static void PushStringLiteral(CompileEnv *envPtr, - * const char *string); */ #define PushLiteral(envPtr, string, length) \ TclEmitPush(TclRegisterLiteral((envPtr), (string), (length), 0), (envPtr)) -#define PushStringLiteral(envPtr, string) \ - PushLiteral((envPtr), (string), sizeof(string "") - 1) /* - * Macro to advance to the next token; it is more mnemonic than the address - * arithmetic that it replaces. The ANSI C "prototype" for this macro is: - * - * static Tcl_Token * TokenAfter(Tcl_Token *tokenPtr); + * Function to advance to the next token; it is more mnemonic than the address + * arithmetic that it replaces. */ - -#define TokenAfter(tokenPtr) \ - ((tokenPtr) + ((tokenPtr)->numComponents + 1)) - -/* - * Macro to get the offset to the next instruction to be issued. The ANSI C - * "prototype" for this macro is: - * - * static ptrdiff_t CurrentOffset(CompileEnv *envPtr); - */ - -#define CurrentOffset(envPtr) \ - ((envPtr)->codeNext - (envPtr)->codeStart) +static inline Tcl_Token * +TokenAfter( + Tcl_Token *tokenPtr) +{ + return tokenPtr + (tokenPtr->numComponents + 1); +} /* * Note: the exceptDepth is a bit of a misnomer: TEBC only needs the @@ -1588,20 +1878,36 @@ TclUpdateStackReqs( * of LOOP ranges is an interesting datum for debugging purposes, and that is * what we compute now. * - * static int ExceptionRangeStarts(CompileEnv *envPtr, Tcl_Size index); + * static Tcl_Size ExceptionRangeStarts(CompileEnv *envPtr, Tcl_Size index); * static void ExceptionRangeEnds(CompileEnv *envPtr, Tcl_Size index); * static void ExceptionRangeTarget(CompileEnv *envPtr, Tcl_Size index, LABEL); */ -#define ExceptionRangeStarts(envPtr, index) \ - (((envPtr)->exceptDepth++), \ - ((envPtr)->maxExceptDepth = \ - TclMax((envPtr)->exceptDepth, (envPtr)->maxExceptDepth)), \ - ((envPtr)->exceptArrayPtr[(index)].codeOffset = CurrentOffset(envPtr))) -#define ExceptionRangeEnds(envPtr, index) \ - (((envPtr)->exceptDepth--), \ - ((envPtr)->exceptArrayPtr[(index)].numCodeBytes = \ - CurrentOffset(envPtr) - (int)(envPtr)->exceptArrayPtr[(index)].codeOffset)) +static inline Tcl_Size +ExceptionRangeStarts( + CompileEnv *envPtr, + Tcl_ExceptionRange index) +{ + Tcl_Size offset; + + envPtr->exceptDepth++; + envPtr->maxExceptDepth = TclMax(envPtr->exceptDepth, + envPtr->maxExceptDepth); + offset = CurrentOffset(envPtr); + envPtr->exceptArrayPtr[index].codeOffset = offset; + return offset; +} + +static inline void +ExceptionRangeEnds( + CompileEnv *envPtr, + Tcl_ExceptionRange index) +{ + envPtr->exceptDepth--; + envPtr->exceptArrayPtr[index].numCodeBytes = + CurrentOffset(envPtr) - envPtr->exceptArrayPtr[index].codeOffset; +} + #define ExceptionRangeTarget(envPtr, index, targetType) \ ((envPtr)->exceptArrayPtr[(index)].targetType = CurrentOffset(envPtr)) @@ -1611,6 +1917,9 @@ TclUpdateStackReqs( #define EnvHasLVT(envPtr) \ (envPtr->procPtr || envPtr->iPtr->varFramePtr->localCachePtr) +// Stricter than EnvHasLVT; guarantees AnonymousLocal won't fail +#define EnvIsProc(envPtr) \ + (envPtr->procPtr != NULL) /* * Macros for making it easier to deal with tokens and DStrings. @@ -1619,15 +1928,17 @@ TclUpdateStackReqs( #define TclDStringAppendToken(dsPtr, tokenPtr) \ Tcl_DStringAppend((dsPtr), (tokenPtr)->start, (tokenPtr)->size) #define TclRegisterDStringLiteral(envPtr, dsPtr) \ - TclRegisterLiteral(envPtr, Tcl_DStringValue(dsPtr), \ + TclRegisterLiteral(envPtr, Tcl_DStringValue(dsPtr), \ Tcl_DStringLength(dsPtr), /*flags*/ 0) +#define TclPushDString(envPtr, dsPtr) \ + TclEmitPush(TclRegisterDStringLiteral((envPtr), (dsPtr)), (envPtr)) /* * Macro that encapsulates an efficiency trick that avoids a function call for * the simplest of compiles. The ANSI C "prototype" for this macro is: * * static void CompileWord(CompileEnv *envPtr, Tcl_Token *tokenPtr, - * Tcl_Interp *interp, int word); + * Tcl_Interp *interp, Tcl_Size word); */ #define CompileWord(envPtr, tokenPtr, interp, word) \ @@ -1644,32 +1955,34 @@ TclUpdateStackReqs( * i.e. move, the array. This is also the reason to save the nuloc now, it may * change during the course of the function. * - * Macro to encapsulate the variable definition and setup. + * Macros to encapsulate the variable definition and setup. */ #define DefineLineInformation \ - ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \ - Tcl_Size eclIndex = mapPtr->nuloc - 1 + LineInformation lineInfo = { \ + envPtr->extCmdMapPtr, \ + envPtr->extCmdMapPtr->nuloc - 1 \ + } -#define SetLineInformation(word) \ - envPtr->line = mapPtr->loc[eclIndex].line[(word)]; \ - envPtr->clNext = mapPtr->loc[eclIndex].next[(word)] +#define ExtCmdLocation \ + lineInfo.mapPtr->loc[lineInfo.eclIndex] -#define PushVarNameWord(i,v,e,f,l,sc,word) \ - SetLineInformation(word); \ - TclPushVarName(i,v,e,f,l,sc) +#define SetLineInformation(word) \ + do { \ + ECL *eclPtr = &ExtCmdLocation; \ + envPtr->line = eclPtr->line[(word)]; \ + envPtr->clNext = eclPtr->next[(word)]; \ + } while (0) -/* - * Often want to issue one of two versions of an instruction based on whether - * the argument will fit in a single byte or not. This makes it much clearer. - */ +#define PushVarNameWord(varTokenPtr,flags,localIndexPtr,isScalarPtr,wordIndex) \ + do { \ + SetLineInformation(wordIndex); \ + TclPushVarName(interp, varTokenPtr, envPtr, flags, \ + localIndexPtr, isScalarPtr); \ + } while (0) -#define Emit14Inst(nm,idx,envPtr) \ - if (idx <= 255) { \ - TclEmitInstInt1(nm##1,idx,envPtr); \ - } else { \ - TclEmitInstInt4(nm##4,idx,envPtr); \ - } +#define ClearFailedCompile(envPtr) \ + TclClearFailedCompile((envPtr), &lineInfo) /* * How to get an anonymous local variable (used for holding temporary values @@ -1685,17 +1998,198 @@ TclUpdateStackReqs( /* * Flags bits used by TclPushVarName. + * + * TCL_NO_LARGE_INDEX is deprecated entirely; variable indices are always large + * in bytecodes we now issue. */ - -#define TCL_NO_LARGE_INDEX 1 /* Do not return localIndex value > 255 */ -#define TCL_NO_ELEMENT 2 /* Do not push the array element. */ +enum PushVarNameFlags { + // TCL_NO_LARGE_INDEX = 1, /* Do not return localIndex value > 255 */ + TCL_NO_ELEMENT = 2 /* Do not push the array element. */ +}; /* * Flags bits used by lreplace4 instruction */ -#define TCL_LREPLACE4_END_IS_LAST 1 /* "end" refers to last element */ -#define TCL_LREPLACE4_SINGLE_INDEX 2 /* Second index absent (pure insert) */ +enum Lreplace4Flags { + TCL_LREPLACE_END_IS_LAST = 1, /* "end" refers to last element */ + TCL_LREPLACE_SINGLE_INDEX = 2, /* Second index absent (pure insert) */ + TCL_LREPLACE_NEED_IN_RANGE = 4 /* First index must resolve to real list index */ +}; + +/* Flags bits used by arithSeries instruction */ +enum ArithSeqriesFlags { + TCL_ARITHSERIES_FROM = 1 << 0, // from is defined (conventionally empty otherwise) + TCL_ARITHSERIES_TO = 1 << 1, // to is defined (conventionally empty otherwise) + TCL_ARITHSERIES_STEP = 1 << 2, // step is defined (conventionally empty otherwise) + TCL_ARITHSERIES_COUNT = 1 << 3, // count is defined (conventionally empty otherwise) +}; + +/* + * Helper functions for jump tables that call other internal API bits. + */ +static inline Tcl_Size +RegisterJumptable( + JumptableInfo *jtPtr, + CompileEnv *envPtr) +{ + return TclCreateAuxData(jtPtr, &tclJumptableInfoType, envPtr); +} + +static inline Tcl_Size +RegisterJumptableNum( + JumptableNumInfo *jtPtr, + CompileEnv *envPtr) +{ + return TclCreateAuxData(jtPtr, &tclJumptableNumericInfoType, envPtr); +} + +/* + * The type of "labels" used in FWDLABEL() and BACKLABEL(). Logically, the + * result of CurrentOffset(), but specifically not just that. + */ +typedef Tcl_Size Tcl_BytecodeLabel; + +/* + * Used to indicate that no jump is pending resolution. + */ +#define NO_PENDING_JUMP ((Tcl_Size) -1) + +/* + * Shorthand macros for instruction issuing. + */ + + // Measure the length of a string literal. +#define LENGTH_OF(str) \ + ((Tcl_Size) sizeof(str "") - 1) + +// Issue an instruction without an argument. +#define OP(name) TclEmitOpcode(INST_##name, envPtr) +// Issue an instruction with a single-byte argument. +#define OP1(name,val) TclEmitInstInt1(INST_##name,(val),envPtr) +// Issue an instruction with a four-byte argument. +#define OP4(name,val) TclEmitInstInt4(INST_##name,(val),envPtr) +// Issue an instruction with a single-byte argument and a four-byte argument. +#define OP14(name,val1,val2) \ + TclEmitInstInt14(INST_##name, (unsigned)(val1), (unsigned)(val2), envPtr) +// Issue an instruction with two four-byte arguments. +#define OP44(name,val1,val2) \ + TclEmitInstInt44(INST_##name, (unsigned)(val1), (unsigned)(val2), envPtr) +// Issue an instruction with a foun-byte argument and a single-byte argument. +#define OP41(name,val1,val2) \ + TclEmitInstInt41(INST_##name, (unsigned)(val1), (unsigned)(val2), envPtr) +// Issue a potentially break/continue generating instruction without an argument. +#define INVOKE(name) \ + TclEmitInvoke(envPtr,INST_##name) +// Issue a potentially break/continue generating instruction with a single argument. +#define INVOKE4(name,arg1) \ + TclEmitInvoke(envPtr,INST_##name,(int)(arg1)) +// Issue a potentially break/continue generating instruction with two arguments. +#define INVOKE41(name,arg1,arg2) \ + TclEmitInvoke(envPtr,INST_##name,(int)(arg1),(int)(arg2)) + +// Push a string literal. +#define PUSH(string) \ + PushLiteral((envPtr), (string), LENGTH_OF(string)) +// Push a string whose is computed with strlen(). +#define PUSH_STRING(strVar) \ + PushLiteral(envPtr, (strVar), TCL_AUTO_LENGTH) +// Push a string from a TCL_TOKEN_SIMPLE_WORD token. +#define PUSH_SIMPLE_TOKEN(tokenPtr) \ + PushLiteral(envPtr, (tokenPtr)[1].start, (tokenPtr)[1].size) +// Push a string from a TCL_TOKEN_SIMPLE_WORD token where that is a command. +#define PUSH_COMMAND_TOKEN(tokenPtr) \ + TclEmitPush(TclRegisterLiteral(envPtr, \ + (tokenPtr)[1].start, (tokenPtr)[1].size, LITERAL_CMD_NAME), \ + envPtr) +// Take a reference to a Tcl_Obj and arrange for it to be pushed. +#define PUSH_OBJ(objPtr) \ + TclEmitPush(TclAddLiteralObj(envPtr, (objPtr), NULL), envPtr) +// Take a reference to a Tcl_Obj and arrange for it to be pushed. +// Handles extra flags, typically used for command names. +#define PUSH_OBJ_FLAGS(objPtr, flags) \ + TclEmitPush(TclRegisterLiteralObj(envPtr, (objPtr), (flags)), envPtr) +// Push a general token. Needs which index of its command it is. +#define PUSH_TOKEN(tokenPtr, index) \ + CompileWord(envPtr, (tokenPtr), interp, (index)) +// Push a token that is an expression. +#define PUSH_EXPR_TOKEN(tokenPtr, index) \ + do { \ + SetLineInformation(index); \ + TclCompileExprWords(interp, (tokenPtr), 1, envPtr); \ + } while (0) +// Compile the body of a command (e.g., [if], [while]) +#define BODY(tokenPtr, index) \ + do { \ + SetLineInformation((index)); \ + TclCompileCmdWord(interp, \ + (tokenPtr)+1, (tokenPtr)->numComponents, \ + envPtr); \ + } while (0) + +// Set the label to the current address. Typically paired with BACKJUMP. +#define BACKLABEL(var) \ + (var)=CurrentOffset(envPtr) +// Jump (of given type) backwards to the label defined by BACKLABEL. +#define BACKJUMP(name, var) \ + TclEmitInstInt4(INST_##name,(var)-CurrentOffset(envPtr),envPtr) +// Jump (of given type) forwards to the label defined by FWDLABEL. +#define FWDJUMP(name, var) \ + (var)=CurrentOffset(envPtr);TclEmitInstInt4(INST_##name,0,envPtr) +// Set the label to the current address. MUST be paired with FWDJUMP. +#define FWDLABEL(var) \ + TclStoreInt4AtPtr(CurrentOffset(envPtr)-(var),envPtr->codeStart+(var)+1) + +// Create an unplaced CATCH exception range. +#define MAKE_CATCH_RANGE() \ + TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr) +// Create an unplaced LOOP exception range. +#define MAKE_LOOP_RANGE() \ + TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr) +#define CATCH_RANGE_VAR(range,var) \ + for(int var=(ExceptionRangeStarts(envPtr,(range)), 0); \ + !var; \ + var=(ExceptionRangeEnds(envPtr,(range)), 1)) +// Wrap the given range around a body of code, placing its start and end. +#define CATCH_RANGE(range) \ + CATCH_RANGE_VAR((range), JOIN(catchRange_, __LINE__)) +// Define where caught exceptions in the CATCH range branch to. +#define CATCH_TARGET(range) \ + ExceptionRangeTarget(envPtr, (range), catchOffset) +// Define where caught BREAKs in the LOOP range branch to. +#define BREAK_TARGET(range) \ + ExceptionRangeTarget(envPtr, (range), breakOffset) +// Define where caught CONTINUEs in the LOOP range branch to. +#define CONTINUE_TARGET(range) \ + ExceptionRangeTarget(envPtr, (range), continueOffset) +// Finalize the LOOP exception range, setting the destinations for jumps. +#define FINALIZE_LOOP(range) \ + TclFinalizeLoopExceptionRange(envPtr, (range)) + +// Apply a correction to the stack depth. +#define STKDELTA(delta) \ + TclAdjustStackDepth((delta), envPtr) + +// Convert a TCL_TOKEN_SIMPLE_WORD token to a Tcl_Obj. +#define TokenToObj(tokenPtr) \ + Tcl_NewStringObj((tokenPtr)[1].start, (tokenPtr)[1].size) +// Test if a token is literally a given string. +#define IS_TOKEN_LITERALLY(tokenPtr, str) \ + (((tokenPtr)->type == TCL_TOKEN_SIMPLE_WORD) \ + && ((tokenPtr)[1].size == LENGTH_OF(str)) \ + && strncmp((tokenPtr)[1].start, str, LENGTH_OF(str)) == 0) +// Test if a token is a prefix of a given string. +#define IS_TOKEN_PREFIX(tokenPtr, minLength, str) \ + (((tokenPtr)->type == TCL_TOKEN_SIMPLE_WORD) \ + && ((tokenPtr)[1].size >= (Tcl_Size)(minLength)) \ + && ((tokenPtr)[1].size <= LENGTH_OF(str)) \ + && strncmp((tokenPtr)[1].start, str, (tokenPtr)[1].size) == 0) +// Test if a token has a given string as a prefix. +#define IS_TOKEN_PREFIXED_BY(tokenPtr, str) \ + (((tokenPtr)->type == TCL_TOKEN_SIMPLE_WORD) \ + && ((tokenPtr)[1].size > LENGTH_OF(str)) \ + && strncmp((tokenPtr)[1].start, str, LENGTH_OF(str)) == 0) + /* * DTrace probe macros (NOPs if DTrace support is not enabled). */ diff --git a/generic/tclConfig.c b/generic/tclConfig.c index 7a7ce37..a7b557d 100644 --- a/generic/tclConfig.c +++ b/generic/tclConfig.c @@ -390,7 +390,7 @@ GetConfigDict( static void ConfigDictDeleteProc( - void *clientData, /* Pointer to Tcl_Obj. */ + void *clientData, /* Pointer to Tcl_Obj. */ TCL_UNUSED(Tcl_Interp *)) { Tcl_DecrRefCount((Tcl_Obj *)clientData); diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 7ce3ac8..70c0191 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -61,18 +61,18 @@ EXTERN const char * Tcl_PkgRequireEx(Tcl_Interp *interp, /* 2 */ EXTERN TCL_NORETURN void Tcl_Panic(const char *format, ...) TCL_FORMAT_PRINTF(1, 2); /* 3 */ -EXTERN void * Tcl_Alloc(TCL_HASH_TYPE size); +EXTERN void * Tcl_Alloc(size_t size); /* 4 */ EXTERN void Tcl_Free(void *ptr); /* 5 */ -EXTERN void * Tcl_Realloc(void *ptr, TCL_HASH_TYPE size); +EXTERN void * Tcl_Realloc(void *ptr, size_t size); /* 6 */ -EXTERN void * Tcl_DbCkalloc(TCL_HASH_TYPE size, const char *file, +EXTERN void * Tcl_DbCkalloc(size_t size, const char *file, int line); /* 7 */ EXTERN void Tcl_DbCkfree(void *ptr, const char *file, int line); /* 8 */ -EXTERN void * Tcl_DbCkrealloc(void *ptr, TCL_HASH_TYPE size, +EXTERN void * Tcl_DbCkrealloc(void *ptr, size_t size, const char *file, int line); /* 9 */ EXTERN void Tcl_CreateFileHandler(int fd, int mask, @@ -128,15 +128,9 @@ EXTERN Tcl_Obj * Tcl_DbNewStringObj(const char *bytes, EXTERN Tcl_Obj * Tcl_DuplicateObj(Tcl_Obj *objPtr); /* 30 */ EXTERN void TclFreeObj(Tcl_Obj *objPtr); -/* 31 */ -EXTERN int Tcl_GetBoolean(Tcl_Interp *interp, const char *src, - int *intPtr); -/* 32 */ -EXTERN int Tcl_GetBooleanFromObj(Tcl_Interp *interp, - Tcl_Obj *objPtr, int *intPtr); -/* 33 */ -EXTERN unsigned char * Tcl_GetByteArrayFromObj(Tcl_Obj *objPtr, - Tcl_Size *numBytesPtr); +/* Slot 31 is reserved */ +/* Slot 32 is reserved */ +/* Slot 33 is reserved */ /* 34 */ EXTERN int Tcl_GetDouble(Tcl_Interp *interp, const char *src, double *doublePtr); @@ -247,8 +241,7 @@ EXTERN void Tcl_CallWhenDeleted(Tcl_Interp *interp, /* 80 */ EXTERN void Tcl_CancelIdleCall(Tcl_IdleProc *idleProc, void *clientData); -/* 81 */ -EXTERN int Tcl_Close(Tcl_Interp *interp, Tcl_Channel chan); +/* Slot 81 is reserved */ /* 82 */ EXTERN int Tcl_CommandComplete(const char *cmd); /* 83 */ @@ -901,8 +894,7 @@ EXTERN Tcl_Size Tcl_WriteChars(Tcl_Channel chan, const char *src, Tcl_Size srcLen); /* 339 */ EXTERN Tcl_Size Tcl_WriteObj(Tcl_Channel chan, Tcl_Obj *objPtr); -/* 340 */ -EXTERN char * Tcl_GetString(Tcl_Obj *objPtr); +/* Slot 340 is reserved */ /* Slot 341 is reserved */ /* Slot 342 is reserved */ /* 343 */ @@ -1036,7 +1028,7 @@ EXTERN void Tcl_MutexFinalize(Tcl_Mutex *mutex); /* 393 */ EXTERN int Tcl_CreateThread(Tcl_ThreadId *idPtr, Tcl_ThreadCreateProc *proc, void *clientData, - TCL_HASH_TYPE stackSize, int flags); + size_t stackSize, int flags); /* 394 */ EXTERN Tcl_Size Tcl_ReadRaw(Tcl_Channel chan, char *dst, Tcl_Size bytesToRead); @@ -1101,7 +1093,10 @@ EXTERN void Tcl_ClearChannelHandlers(Tcl_Channel channel); EXTERN int Tcl_IsChannelExisting(const char *channelName); /* Slot 419 is reserved */ /* Slot 420 is reserved */ -/* Slot 421 is reserved */ +/* 421 */ +EXTERN Tcl_HashEntry * Tcl_DbCreateHashEntry(Tcl_HashTable *tablePtr, + const void *key, int *newPtr, + const char *file, int line); /* 422 */ EXTERN Tcl_HashEntry * Tcl_CreateHashEntry(Tcl_HashTable *tablePtr, const void *key, int *newPtr); @@ -1124,14 +1119,14 @@ EXTERN void Tcl_UntraceCommand(Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *proc, void *clientData); /* 428 */ -EXTERN void * Tcl_AttemptAlloc(TCL_HASH_TYPE size); +EXTERN void * Tcl_AttemptAlloc(size_t size); /* 429 */ -EXTERN void * Tcl_AttemptDbCkalloc(TCL_HASH_TYPE size, - const char *file, int line); +EXTERN void * Tcl_AttemptDbCkalloc(size_t size, const char *file, + int line); /* 430 */ -EXTERN void * Tcl_AttemptRealloc(void *ptr, TCL_HASH_TYPE size); +EXTERN void * Tcl_AttemptRealloc(void *ptr, size_t size); /* 431 */ -EXTERN void * Tcl_AttemptDbCkrealloc(void *ptr, TCL_HASH_TYPE size, +EXTERN void * Tcl_AttemptDbCkrealloc(void *ptr, size_t size, const char *file, int line); /* 432 */ EXTERN int Tcl_AttemptSetObjLength(Tcl_Obj *objPtr, @@ -1713,7 +1708,7 @@ EXTERN int TclZipfs_MountBuffer(Tcl_Interp *interp, EXTERN void Tcl_FreeInternalRep(Tcl_Obj *objPtr); /* 637 */ EXTERN char * Tcl_InitStringRep(Tcl_Obj *objPtr, const char *bytes, - TCL_HASH_TYPE numBytes); + size_t numBytes); /* 638 */ EXTERN Tcl_ObjInternalRep * Tcl_FetchInternalRep(Tcl_Obj *objPtr, const Tcl_ObjType *typePtr); @@ -1876,6 +1871,22 @@ EXTERN Tcl_Obj * Tcl_NewWideUIntObj(Tcl_WideUInt wideValue); EXTERN void Tcl_SetWideUIntObj(Tcl_Obj *objPtr, Tcl_WideUInt uwideValue); /* 690 */ +EXTERN int Tcl_IsEmpty(Tcl_Obj *obj); +/* 691 */ +EXTERN const char * Tcl_GetEncodingNameForUser(Tcl_DString *bufPtr); +/* 692 */ +EXTERN int Tcl_ListObjReverse(Tcl_Interp *interp, + Tcl_Obj *objPtr, Tcl_Obj **resultPtrPtr); +/* 693 */ +EXTERN int Tcl_ListObjRepeat(Tcl_Interp *interp, + Tcl_Size repeatCount, Tcl_Size objc, + Tcl_Obj *const objv[], + Tcl_Obj **resultPtrPtr); +/* 694 */ +EXTERN int Tcl_ListObjRange(Tcl_Interp *interp, Tcl_Obj *objPtr, + Tcl_Size start, Tcl_Size end, + Tcl_Obj **resultPtrPtr); +/* 695 */ EXTERN void TclUnusedStubEntry(void); typedef struct { @@ -1891,12 +1902,12 @@ typedef struct TclStubs { int (*tcl_PkgProvideEx) (Tcl_Interp *interp, const char *name, const char *version, const void *clientData); /* 0 */ const char * (*tcl_PkgRequireEx) (Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 1 */ TCL_NORETURN1 void (*tcl_Panic) (const char *format, ...) TCL_FORMAT_PRINTF(1, 2); /* 2 */ - void * (*tcl_Alloc) (TCL_HASH_TYPE size); /* 3 */ + void * (*tcl_Alloc) (size_t size); /* 3 */ void (*tcl_Free) (void *ptr); /* 4 */ - void * (*tcl_Realloc) (void *ptr, TCL_HASH_TYPE size); /* 5 */ - void * (*tcl_DbCkalloc) (TCL_HASH_TYPE size, const char *file, int line); /* 6 */ + void * (*tcl_Realloc) (void *ptr, size_t size); /* 5 */ + void * (*tcl_DbCkalloc) (size_t size, const char *file, int line); /* 6 */ void (*tcl_DbCkfree) (void *ptr, const char *file, int line); /* 7 */ - void * (*tcl_DbCkrealloc) (void *ptr, TCL_HASH_TYPE size, const char *file, int line); /* 8 */ + void * (*tcl_DbCkrealloc) (void *ptr, size_t size, const char *file, int line); /* 8 */ void (*tcl_CreateFileHandler) (int fd, int mask, Tcl_FileProc *proc, void *clientData); /* 9 */ void (*tcl_DeleteFileHandler) (int fd); /* 10 */ void (*tcl_SetTimer) (const Tcl_Time *timePtr); /* 11 */ @@ -1919,9 +1930,9 @@ typedef struct TclStubs { Tcl_Obj * (*tcl_DbNewStringObj) (const char *bytes, Tcl_Size length, const char *file, int line); /* 28 */ Tcl_Obj * (*tcl_DuplicateObj) (Tcl_Obj *objPtr); /* 29 */ void (*tclFreeObj) (Tcl_Obj *objPtr); /* 30 */ - int (*tcl_GetBoolean) (Tcl_Interp *interp, const char *src, int *intPtr); /* 31 */ - int (*tcl_GetBooleanFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *intPtr); /* 32 */ - unsigned char * (*tcl_GetByteArrayFromObj) (Tcl_Obj *objPtr, Tcl_Size *numBytesPtr); /* 33 */ + void (*reserved31)(void); + void (*reserved32)(void); + void (*reserved33)(void); int (*tcl_GetDouble) (Tcl_Interp *interp, const char *src, double *doublePtr); /* 34 */ int (*tcl_GetDoubleFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, double *doublePtr); /* 35 */ void (*reserved36)(void); @@ -1969,7 +1980,7 @@ typedef struct TclStubs { int (*tcl_BadChannelOption) (Tcl_Interp *interp, const char *optionName, const char *optionList); /* 78 */ void (*tcl_CallWhenDeleted) (Tcl_Interp *interp, Tcl_InterpDeleteProc *proc, void *clientData); /* 79 */ void (*tcl_CancelIdleCall) (Tcl_IdleProc *idleProc, void *clientData); /* 80 */ - int (*tcl_Close) (Tcl_Interp *interp, Tcl_Channel chan); /* 81 */ + void (*reserved81)(void); int (*tcl_CommandComplete) (const char *cmd); /* 82 */ char * (*tcl_Concat) (Tcl_Size argc, const char *const *argv); /* 83 */ Tcl_Size (*tcl_ConvertElement) (const char *src, char *dst, int flags); /* 84 */ @@ -2228,7 +2239,7 @@ typedef struct TclStubs { Tcl_Size (*tcl_UtfToUpper) (char *src); /* 337 */ Tcl_Size (*tcl_WriteChars) (Tcl_Channel chan, const char *src, Tcl_Size srcLen); /* 338 */ Tcl_Size (*tcl_WriteObj) (Tcl_Channel chan, Tcl_Obj *objPtr); /* 339 */ - char * (*tcl_GetString) (Tcl_Obj *objPtr); /* 340 */ + void (*reserved340)(void); void (*reserved341)(void); void (*reserved342)(void); void (*tcl_AlertNotifier) (void *clientData); /* 343 */ @@ -2281,7 +2292,7 @@ typedef struct TclStubs { int (*tcl_ProcObjCmd) (void *clientData, Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[]); /* 390 */ void (*tcl_ConditionFinalize) (Tcl_Condition *condPtr); /* 391 */ void (*tcl_MutexFinalize) (Tcl_Mutex *mutex); /* 392 */ - int (*tcl_CreateThread) (Tcl_ThreadId *idPtr, Tcl_ThreadCreateProc *proc, void *clientData, TCL_HASH_TYPE stackSize, int flags); /* 393 */ + int (*tcl_CreateThread) (Tcl_ThreadId *idPtr, Tcl_ThreadCreateProc *proc, void *clientData, size_t stackSize, int flags); /* 393 */ Tcl_Size (*tcl_ReadRaw) (Tcl_Channel chan, char *dst, Tcl_Size bytesToRead); /* 394 */ Tcl_Size (*tcl_WriteRaw) (Tcl_Channel chan, const char *src, Tcl_Size srcLen); /* 395 */ Tcl_Channel (*tcl_GetTopChannel) (Tcl_Channel chan); /* 396 */ @@ -2309,17 +2320,17 @@ typedef struct TclStubs { int (*tcl_IsChannelExisting) (const char *channelName); /* 418 */ void (*reserved419)(void); void (*reserved420)(void); - void (*reserved421)(void); + Tcl_HashEntry * (*tcl_DbCreateHashEntry) (Tcl_HashTable *tablePtr, const void *key, int *newPtr, const char *file, int line); /* 421 */ Tcl_HashEntry * (*tcl_CreateHashEntry) (Tcl_HashTable *tablePtr, const void *key, int *newPtr); /* 422 */ void (*tcl_InitCustomHashTable) (Tcl_HashTable *tablePtr, int keyType, const Tcl_HashKeyType *typePtr); /* 423 */ void (*tcl_InitObjHashTable) (Tcl_HashTable *tablePtr); /* 424 */ void * (*tcl_CommandTraceInfo) (Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *procPtr, void *prevClientData); /* 425 */ int (*tcl_TraceCommand) (Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *proc, void *clientData); /* 426 */ void (*tcl_UntraceCommand) (Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *proc, void *clientData); /* 427 */ - void * (*tcl_AttemptAlloc) (TCL_HASH_TYPE size); /* 428 */ - void * (*tcl_AttemptDbCkalloc) (TCL_HASH_TYPE size, const char *file, int line); /* 429 */ - void * (*tcl_AttemptRealloc) (void *ptr, TCL_HASH_TYPE size); /* 430 */ - void * (*tcl_AttemptDbCkrealloc) (void *ptr, TCL_HASH_TYPE size, const char *file, int line); /* 431 */ + void * (*tcl_AttemptAlloc) (size_t size); /* 428 */ + void * (*tcl_AttemptDbCkalloc) (size_t size, const char *file, int line); /* 429 */ + void * (*tcl_AttemptRealloc) (void *ptr, size_t size); /* 430 */ + void * (*tcl_AttemptDbCkrealloc) (void *ptr, size_t size, const char *file, int line); /* 431 */ int (*tcl_AttemptSetObjLength) (Tcl_Obj *objPtr, Tcl_Size length); /* 432 */ Tcl_ThreadId (*tcl_GetChannelThread) (Tcl_Channel channel); /* 433 */ Tcl_UniChar * (*tclGetUnicodeFromObj) (Tcl_Obj *objPtr, void *lengthPtr); /* 434 */ @@ -2525,7 +2536,7 @@ typedef struct TclStubs { Tcl_Obj * (*tclZipfs_TclLibrary) (void); /* 634 */ int (*tclZipfs_MountBuffer) (Tcl_Interp *interp, const void *data, size_t datalen, const char *mountPoint, int copy); /* 635 */ void (*tcl_FreeInternalRep) (Tcl_Obj *objPtr); /* 636 */ - char * (*tcl_InitStringRep) (Tcl_Obj *objPtr, const char *bytes, TCL_HASH_TYPE numBytes); /* 637 */ + char * (*tcl_InitStringRep) (Tcl_Obj *objPtr, const char *bytes, size_t numBytes); /* 637 */ Tcl_ObjInternalRep * (*tcl_FetchInternalRep) (Tcl_Obj *objPtr, const Tcl_ObjType *typePtr); /* 638 */ void (*tcl_StoreInternalRep) (Tcl_Obj *objPtr, const Tcl_ObjType *typePtr, const Tcl_ObjInternalRep *irPtr); /* 639 */ int (*tcl_HasStringRep) (Tcl_Obj *objPtr); /* 640 */ @@ -2578,7 +2589,12 @@ typedef struct TclStubs { int (*tcl_UtfNcasecmp) (const char *s1, const char *s2, size_t n); /* 687 */ Tcl_Obj * (*tcl_NewWideUIntObj) (Tcl_WideUInt wideValue); /* 688 */ void (*tcl_SetWideUIntObj) (Tcl_Obj *objPtr, Tcl_WideUInt uwideValue); /* 689 */ - void (*tclUnusedStubEntry) (void); /* 690 */ + int (*tcl_IsEmpty) (Tcl_Obj *obj); /* 690 */ + const char * (*tcl_GetEncodingNameForUser) (Tcl_DString *bufPtr); /* 691 */ + int (*tcl_ListObjReverse) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Obj **resultPtrPtr); /* 692 */ + int (*tcl_ListObjRepeat) (Tcl_Interp *interp, Tcl_Size repeatCount, Tcl_Size objc, Tcl_Obj *const objv[], Tcl_Obj **resultPtrPtr); /* 693 */ + int (*tcl_ListObjRange) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Size start, Tcl_Size end, Tcl_Obj **resultPtrPtr); /* 694 */ + void (*tclUnusedStubEntry) (void); /* 695 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -2653,12 +2669,9 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_DuplicateObj) /* 29 */ #define TclFreeObj \ (tclStubsPtr->tclFreeObj) /* 30 */ -#define Tcl_GetBoolean \ - (tclStubsPtr->tcl_GetBoolean) /* 31 */ -#define Tcl_GetBooleanFromObj \ - (tclStubsPtr->tcl_GetBooleanFromObj) /* 32 */ -#define Tcl_GetByteArrayFromObj \ - (tclStubsPtr->tcl_GetByteArrayFromObj) /* 33 */ +/* Slot 31 is reserved */ +/* Slot 32 is reserved */ +/* Slot 33 is reserved */ #define Tcl_GetDouble \ (tclStubsPtr->tcl_GetDouble) /* 34 */ #define Tcl_GetDoubleFromObj \ @@ -2742,8 +2755,7 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_CallWhenDeleted) /* 79 */ #define Tcl_CancelIdleCall \ (tclStubsPtr->tcl_CancelIdleCall) /* 80 */ -#define Tcl_Close \ - (tclStubsPtr->tcl_Close) /* 81 */ +/* Slot 81 is reserved */ #define Tcl_CommandComplete \ (tclStubsPtr->tcl_CommandComplete) /* 82 */ #define Tcl_Concat \ @@ -3225,8 +3237,7 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_WriteChars) /* 338 */ #define Tcl_WriteObj \ (tclStubsPtr->tcl_WriteObj) /* 339 */ -#define Tcl_GetString \ - (tclStubsPtr->tcl_GetString) /* 340 */ +/* Slot 340 is reserved */ /* Slot 341 is reserved */ /* Slot 342 is reserved */ #define Tcl_AlertNotifier \ @@ -3378,7 +3389,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_IsChannelExisting) /* 418 */ /* Slot 419 is reserved */ /* Slot 420 is reserved */ -/* Slot 421 is reserved */ +#define Tcl_DbCreateHashEntry \ + (tclStubsPtr->tcl_DbCreateHashEntry) /* 421 */ #define Tcl_CreateHashEntry \ (tclStubsPtr->tcl_CreateHashEntry) /* 422 */ #define Tcl_InitCustomHashTable \ @@ -3912,8 +3924,18 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_NewWideUIntObj) /* 688 */ #define Tcl_SetWideUIntObj \ (tclStubsPtr->tcl_SetWideUIntObj) /* 689 */ +#define Tcl_IsEmpty \ + (tclStubsPtr->tcl_IsEmpty) /* 690 */ +#define Tcl_GetEncodingNameForUser \ + (tclStubsPtr->tcl_GetEncodingNameForUser) /* 691 */ +#define Tcl_ListObjReverse \ + (tclStubsPtr->tcl_ListObjReverse) /* 692 */ +#define Tcl_ListObjRepeat \ + (tclStubsPtr->tcl_ListObjRepeat) /* 693 */ +#define Tcl_ListObjRange \ + (tclStubsPtr->tcl_ListObjRange) /* 694 */ #define TclUnusedStubEntry \ - (tclStubsPtr->tclUnusedStubEntry) /* 690 */ + (tclStubsPtr->tclUnusedStubEntry) /* 695 */ #endif /* defined(USE_TCL_STUBS) */ @@ -3983,23 +4005,6 @@ extern const TclStubs *tclStubsPtr; } while(0) #if defined(USE_TCL_STUBS) -# if defined(_WIN32) && defined(_WIN64) && TCL_MAJOR_VERSION < 9 -# undef Tcl_GetTime -/* Handle Win64 tk.dll being loaded in Cygwin64 (only needed for Tcl 8). */ -# define Tcl_GetTime(t) \ - do { \ - struct { \ - Tcl_Time now; \ - long long reserved; \ - } _t; \ - _t.reserved = -1; \ - tclStubsPtr->tcl_GetTime((&_t.now)); \ - if (_t.reserved != -1) { \ - _t.now.usec = (long) _t.reserved; \ - } \ - *(t) = _t.now; \ - } while (0) -# endif # if defined(__CYGWIN__) && defined(TCL_WIDE_INT_IS_LONG) /* On Cygwin64, long is 64-bit while on Win64 long is 32-bit. Therefore * we have to make sure that all stub entries on Cygwin64 follow the @@ -4029,9 +4034,6 @@ extern const TclStubs *tclStubsPtr; # endif #endif -#undef Tcl_GetString -#undef Tcl_GetUnicode -#undef Tcl_CreateHashEntry #define Tcl_GetString(objPtr) \ Tcl_GetStringFromObj(objPtr, (Tcl_Size *)NULL) #define Tcl_GetUnicode(objPtr) \ @@ -4053,26 +4055,22 @@ extern const TclStubs *tclStubsPtr; #define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \ (tclStubsPtr->tcl_GetIndexFromObjStruct((interp), (objPtr), (tablePtr), (offset), (msg), \ (flags)|(int)(sizeof(*(indexPtr))<<1), (indexPtr))) -#define Tcl_GetBooleanFromObj(interp, objPtr, boolPtr) \ - ((sizeof(*(boolPtr)) == sizeof(int) && (TCL_MAJOR_VERSION == 8)) ? tclStubsPtr->tcl_GetBooleanFromObj(interp, objPtr, (int *)(boolPtr)) : \ - ((sizeof(*(boolPtr)) <= sizeof(int)) ? Tcl_GetBoolFromObj(interp, objPtr, (TCL_NULL_OK-2)&(int)sizeof((*(boolPtr))), (char *)(boolPtr)) : \ - (TCLBOOLWARNING(boolPtr)Tcl_Panic("sizeof(%s) must be <= sizeof(int)", & #boolPtr [1]),TCL_ERROR))) -#define Tcl_GetBoolean(interp, src, boolPtr) \ - ((sizeof(*(boolPtr)) == sizeof(int) && (TCL_MAJOR_VERSION == 8)) ? tclStubsPtr->tcl_GetBoolean(interp, src, (int *)(boolPtr)) : \ - ((sizeof(*(boolPtr)) <= sizeof(int)) ? Tcl_GetBool(interp, src, (TCL_NULL_OK-2)&(int)sizeof((*(boolPtr))), (char *)(boolPtr)) : \ - (TCLBOOLWARNING(boolPtr)Tcl_Panic("sizeof(%s) must be <= sizeof(int)", & #boolPtr [1]),TCL_ERROR))) +#define Tcl_GetBooleanFromObj(interp, objPtr, boolPtr) ((sizeof(*(boolPtr)) <= sizeof(int)) \ + ? Tcl_GetBoolFromObj(interp, objPtr, (TCL_NULL_OK-2)&(int)sizeof((*(boolPtr))), (char *)(boolPtr)) \ + : (TCLBOOLWARNING(boolPtr)Tcl_Panic("sizeof(%s) must be <= sizeof(int)", & #boolPtr [1]),TCL_ERROR)) +#define Tcl_GetBoolean(interp, src, boolPtr) ((sizeof(*(boolPtr)) <= sizeof(int)) \ + ? Tcl_GetBool(interp, src, (TCL_NULL_OK-2)&(int)sizeof((*(boolPtr))), (char *)(boolPtr)) \ + : (TCLBOOLWARNING(boolPtr)Tcl_Panic("sizeof(%s) must be <= sizeof(int)", & #boolPtr [1]),TCL_ERROR)) #else #define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \ ((Tcl_GetIndexFromObjStruct)((interp), (objPtr), (tablePtr), (offset), (msg), \ (flags)|(int)(sizeof(*(indexPtr))<<1), (indexPtr))) -#define Tcl_GetBooleanFromObj(interp, objPtr, boolPtr) \ - ((sizeof(*(boolPtr)) == sizeof(int) && (TCL_MAJOR_VERSION == 8)) ? Tcl_GetBooleanFromObj(interp, objPtr, (int *)(boolPtr)) : \ - ((sizeof(*(boolPtr)) <= sizeof(int)) ? Tcl_GetBoolFromObj(interp, objPtr, (TCL_NULL_OK-2)&(int)sizeof((*(boolPtr))), (char *)(boolPtr)) : \ - (TCLBOOLWARNING(boolPtr)Tcl_Panic("sizeof(%s) must be <= sizeof(int)", & #boolPtr [1]),TCL_ERROR))) -#define Tcl_GetBoolean(interp, src, boolPtr) \ - ((sizeof(*(boolPtr)) == sizeof(int) && (TCL_MAJOR_VERSION == 8)) ? Tcl_GetBoolean(interp, src, (int *)(boolPtr)) : \ - ((sizeof(*(boolPtr)) <= sizeof(int)) ? Tcl_GetBool(interp, src, (TCL_NULL_OK-2)&(int)sizeof((*(boolPtr))), (char *)(boolPtr)) : \ - (TCLBOOLWARNING(boolPtr)Tcl_Panic("sizeof(%s) must be <= sizeof(int)", & #boolPtr [1]),TCL_ERROR))) +#define Tcl_GetBooleanFromObj(interp, objPtr, boolPtr) ((sizeof(*(boolPtr)) <= sizeof(int)) \ + ? Tcl_GetBoolFromObj(interp, objPtr, (TCL_NULL_OK-2)&(int)sizeof((*(boolPtr))), (char *)(boolPtr)) \ + : (TCLBOOLWARNING(boolPtr)Tcl_Panic("sizeof(%s) must be <= sizeof(int)", & #boolPtr [1]),TCL_ERROR)) +#define Tcl_GetBoolean(interp, src, boolPtr) ((sizeof(*(boolPtr)) <= sizeof(int)) \ + ? Tcl_GetBool(interp, src, (TCL_NULL_OK-2)&(int)sizeof((*(boolPtr))), (char *)(boolPtr)) \ + : (TCLBOOLWARNING(boolPtr)Tcl_Panic("sizeof(%s) must be <= sizeof(int)", & #boolPtr [1]),TCL_ERROR)) #endif #ifdef TCL_MEM_DEBUG @@ -4169,11 +4167,7 @@ extern const TclStubs *tclStubsPtr; Tcl_EvalObjEx(interp, objPtr, 0) #define Tcl_GlobalEvalObj(interp, objPtr) \ Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL) - -#if TCL_MAJOR_VERSION > 8 -# undef Tcl_Close -# define Tcl_Close(interp, chan) Tcl_CloseEx(interp, chan, 0) -#endif +#define Tcl_Close(interp, chan) Tcl_CloseEx(interp, chan, 0) #undef TclUtfCharComplete #undef TclUtfNext @@ -4197,81 +4191,7 @@ extern const TclStubs *tclStubsPtr; #undef TclParseArgsObjv #undef TclGetAliasObj -#if TCL_MAJOR_VERSION < 9 - /* TIP #627 */ -# undef Tcl_CreateObjCommand2 -# define Tcl_CreateObjCommand2 Tcl_CreateObjCommand -# undef Tcl_CreateObjTrace2 -# define Tcl_CreateObjTrace2 Tcl_CreateObjTrace -# undef Tcl_NRCreateCommand2 -# define Tcl_NRCreateCommand2 Tcl_NRCreateCommand -# undef Tcl_NRCallObjProc2 -# define Tcl_NRCallObjProc2 Tcl_NRCallObjProc - /* TIP #660 */ -# undef Tcl_GetSizeIntFromObj -# define Tcl_GetSizeIntFromObj Tcl_GetIntFromObj - -# undef Tcl_GetBytesFromObj -# define Tcl_GetBytesFromObj(interp, objPtr, sizePtr) \ - tclStubsPtr->tclGetBytesFromObj((interp), (objPtr), (sizePtr)) -# undef Tcl_GetStringFromObj -# define Tcl_GetStringFromObj(objPtr, sizePtr) \ - tclStubsPtr->tclGetStringFromObj((objPtr), (sizePtr)) -# undef Tcl_GetUnicodeFromObj -# define Tcl_GetUnicodeFromObj(objPtr, sizePtr) \ - tclStubsPtr->tclGetUnicodeFromObj((objPtr), (sizePtr)) -# undef Tcl_ListObjGetElements -# define Tcl_ListObjGetElements(interp, listPtr, objcPtr, objvPtr) \ - tclStubsPtr->tclListObjGetElements((interp), (listPtr), (objcPtr), (objvPtr)) -# undef Tcl_ListObjLength -# define Tcl_ListObjLength(interp, listPtr, lengthPtr) \ - tclStubsPtr->tclListObjLength((interp), (listPtr), (lengthPtr)) -# undef Tcl_DictObjSize -# define Tcl_DictObjSize(interp, dictPtr, sizePtr) \ - tclStubsPtr->tclDictObjSize((interp), (dictPtr), (sizePtr)) -# undef Tcl_SplitList -# define Tcl_SplitList(interp, listStr, argcPtr, argvPtr) \ - tclStubsPtr->tclSplitList((interp), (listStr), (argcPtr), (argvPtr)) -# undef Tcl_SplitPath -# define Tcl_SplitPath(path, argcPtr, argvPtr) \ - tclStubsPtr->tclSplitPath((path), (argcPtr), (argvPtr)) -# undef Tcl_FSSplitPath -# define Tcl_FSSplitPath(pathPtr, lenPtr) \ - tclStubsPtr->tclFSSplitPath((pathPtr), (lenPtr)) -# undef Tcl_ParseArgsObjv -# define Tcl_ParseArgsObjv(interp, argTable, objcPtr, objv, remObjv) \ - tclStubsPtr->tclParseArgsObjv((interp), (argTable), (objcPtr), (objv), (remObjv)) -# undef Tcl_GetAliasObj -# define Tcl_GetAliasObj(interp, childCmd, targetInterpPtr, targetCmdPtr, objcPtr, objv) \ - tclStubsPtr->tclGetAliasObj((interp), (childCmd), (targetInterpPtr), (targetCmdPtr), (objcPtr), (objv)) -# undef Tcl_OpenTcpServerEx -# undef TclZipfs_Mount -# undef TclZipfs_Unmount -# undef TclZipfs_TclLibrary -# undef TclZipfs_MountBuffer -# undef Tcl_FreeInternalRep -# undef Tcl_InitStringRep -# undef Tcl_FetchInternalRep -# undef Tcl_StoreInternalRep -# undef Tcl_HasStringRep -# undef Tcl_LinkArray -# undef Tcl_GetIntForIndex -# undef Tcl_FSTildeExpand -# undef Tcl_ExternalToUtfDStringEx -# undef Tcl_UtfToExternalDStringEx -# undef Tcl_AsyncMarkFromSignal -# undef Tcl_GetBool -# undef Tcl_GetBoolFromObj -# undef Tcl_GetNumberFromObj -# undef Tcl_GetNumber -# undef Tcl_RemoveChannelMode -# undef Tcl_GetEncodingNulLength -# undef Tcl_GetWideUIntFromObj -# undef Tcl_DStringToObj -# undef Tcl_NewWideUIntObj -# undef Tcl_SetWideUIntObj -#elif defined(TCL_8_API) -# undef Tcl_GetByteArrayFromObj +#if defined(TCL_8_API) # undef Tcl_GetBytesFromObj # undef Tcl_GetStringFromObj # undef Tcl_GetUnicodeFromObj @@ -4284,9 +4204,6 @@ extern const TclStubs *tclStubsPtr; # undef Tcl_ParseArgsObjv # undef Tcl_GetAliasObj # if !defined(USE_TCL_STUBS) -# define Tcl_GetByteArrayFromObj(objPtr, sizePtr) (sizeof(*(sizePtr)) <= sizeof(int) ? \ - TclGetBytesFromObj(NULL, (objPtr), (sizePtr)) : \ - (Tcl_GetBytesFromObj)(NULL, (objPtr), (Tcl_Size *)(void *)(sizePtr))) # define Tcl_GetBytesFromObj(interp, objPtr, sizePtr) (sizeof(*(sizePtr)) <= sizeof(int) ? \ TclGetBytesFromObj((interp), (objPtr), (sizePtr)) : \ (Tcl_GetBytesFromObj)((interp), (objPtr), (Tcl_Size *)(void *)(sizePtr))) @@ -4321,9 +4238,6 @@ extern const TclStubs *tclStubsPtr; TclGetAliasObj((interp), (childCmd), (targetInterpPtr), (targetCmdPtr), (objcPtr), (objv)) : \ (Tcl_GetAliasObj)((interp), (childCmd), (targetInterpPtr), (targetCmdPtr), (Tcl_Size *)(void *)(objcPtr), (objv))) # elif !defined(BUILD_tcl) -# define Tcl_GetByteArrayFromObj(objPtr, sizePtr) (sizeof(*(sizePtr)) <= sizeof(int) ? \ - tclStubsPtr->tclGetBytesFromObj(NULL, (objPtr), (sizePtr)) : \ - tclStubsPtr->tcl_GetBytesFromObj(NULL, (objPtr), (Tcl_Size *)(void *)(sizePtr))) # define Tcl_GetBytesFromObj(interp, objPtr, sizePtr) (sizeof(*(sizePtr)) <= sizeof(int) ? \ tclStubsPtr->tclGetBytesFromObj((interp), (objPtr), (sizePtr)) : \ tclStubsPtr->tcl_GetBytesFromObj((interp), (objPtr), (Tcl_Size *)(void *)(sizePtr))) @@ -4358,10 +4272,12 @@ extern const TclStubs *tclStubsPtr; tclStubsPtr->tclGetAliasObj((interp), (childCmd), (targetInterpPtr), (targetCmdPtr), (objcPtr), (objv)) : \ tclStubsPtr->tcl_GetAliasObj((interp), (childCmd), (targetInterpPtr), (targetCmdPtr), (Tcl_Size *)(void *)(objcPtr), (objv))) # endif /* defined(USE_TCL_STUBS) */ -#else /* !defined(TCL_8_API) */ -# undef Tcl_GetByteArrayFromObj -# define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \ - Tcl_GetBytesFromObj(NULL, (objPtr), (sizePtr)) #endif /* defined(TCL_8_API) */ +#define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \ + Tcl_GetBytesFromObj(NULL, (objPtr), (sizePtr)) + +#if TCL_MINOR_VERSION < 1 +# undef Tcl_IsEmpty +#endif #endif /* _TCLDECLS */ diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 505e2b2..03e286a 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -82,8 +82,8 @@ static const EnsembleImplMap implementationMap[] = { {"lappend", DictLappendCmd, TclCompileDictLappendCmd, NULL, NULL, 0 }, {"map", NULL, TclCompileDictMapCmd, DictMapNRCmd, NULL, 0 }, {"merge", DictMergeCmd, TclCompileDictMergeCmd, NULL, NULL, 0 }, - {"remove", DictRemoveCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0 }, - {"replace", DictReplaceCmd, NULL, NULL, NULL, 0 }, + {"remove", DictRemoveCmd, TclCompileDictRemoveCmd, NULL, NULL, 0 }, + {"replace", DictReplaceCmd, TclCompileDictReplaceCmd, NULL, NULL, 0 }, {"set", DictSetCmd, TclCompileDictSetCmd, NULL, NULL, 0 }, {"size", DictSizeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0 }, {"unset", DictUnsetCmd, TclCompileDictUnsetCmd, NULL, NULL, 0 }, @@ -177,7 +177,7 @@ const Tcl_ObjType tclDictType = { static const Tcl_HashKeyType chainHashType = { TCL_HASH_KEY_TYPE_VERSION, - TCL_HASH_KEY_DIRECT_COMPARE, /* allows compare keys by pointers */ + TCL_HASH_KEY_DIRECT_COMPARE, /* allows compare keys by pointers */ TclHashObjKey, TclCompareObjKeys, AllocChainEntry, @@ -546,7 +546,9 @@ UpdateStringOfDict( dst = Tcl_InitStringRep(dictPtr, NULL, bytesNeeded - 1); TclOOM(dst, bytesNeeded); for (i=0,cPtr=dict->entryChainHead; i<numElems; i+=2,cPtr=cPtr->nextPtr) { - flagPtr[i] |= ( i ? TCL_DONT_QUOTE_HASH : 0 ); + if (i) { + flagPtr[i] |= TCL_DONT_QUOTE_HASH; + } keyPtr = (Tcl_Obj *)Tcl_GetHashKey(&dict->table, &cPtr->entry); elem = TclGetStringFromObj(keyPtr, &length); dst += TclConvertElement(elem, length, dst, flagPtr[i]); @@ -1265,7 +1267,7 @@ Tcl_DictObjNext( void Tcl_DictObjDone( - Tcl_DictSearch *searchPtr) /* Pointer to a hash search context. */ + Tcl_DictSearch *searchPtr) /* Pointer to a hash search context. */ { Dict *dict; @@ -1470,7 +1472,7 @@ Tcl_DbNewDictObj( TclDbNewObj(dictPtr, file, line); TclInvalidateStringRep(dictPtr); - dict = (Dict *)Tcl_Alloc(sizeof(Dict)); + dict = (Dict *)Tcl_DbCkalloc(sizeof(Dict), file, line); InitChainTable(dict); dict->epoch = 1; dict->chain = NULL; @@ -1967,8 +1969,8 @@ DictMergeCmd( Tcl_Obj *const *objv) { Tcl_Obj *targetObj, *keyObj = NULL, *valueObj = NULL; - int allocatedDict = 0; - int i, done; + int done, allocatedDict = 0; + int i; Tcl_DictSearch search; if (objc == 1) { @@ -2493,7 +2495,8 @@ DictLappendCmd( Tcl_Obj *const *objv) { Tcl_Obj *dictPtr, *valuePtr, *resultPtr; - int i, allocatedDict = 0, allocatedValue = 0; + int allocatedDict = 0, allocatedValue = 0; + int i; if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "dictVarName key ?value ...?"); @@ -3854,10 +3857,10 @@ TclDictWithFinish( * parameter is >= 0 */ Tcl_Obj *part2Ptr, /* If non-NULL, gives the name of an element * in the array part1. */ - int index, /* Index into the local variable table of the + Tcl_Size index, /* Index into the local variable table of the * variable, or -1. Only used when part1Ptr is * NULL. */ - int pathc, /* The number of elements in the path into the + Tcl_Size pathc, /* The number of elements in the path into the * dictionary. */ Tcl_Obj *const pathv[], /* The elements of the path to the subdict. */ Tcl_Obj *keysPtr) /* List of keys to be synchronized. This is diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index ffc3026..5534b17 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -13,6 +13,7 @@ */ #include "tclInt.h" +#define ALLOW_DEPRECATED_OPCODES #include "tclCompile.h" #include "tclOOInt.h" #include <assert.h> @@ -132,7 +133,7 @@ void TclDebugPrintByteCodeObj( Tcl_Obj *objPtr) /* The bytecode object to disassemble. */ { - if (tclTraceCompile >= 2) { + if (tclTraceCompile >= TCL_TRACE_BYTECODE_COMPILE_DETAIL) { Tcl_Obj *bufPtr = DisassembleByteCodeObj(objPtr); fprintf(stdout, "\n%s", TclGetString(bufPtr)); @@ -280,8 +281,11 @@ DisassembleByteCodeObj( */ Tcl_AppendPrintfToObj(bufferObj, - "ByteCode %p, refCt %" TCL_SIZE_MODIFIER "d, epoch %" TCL_SIZE_MODIFIER "d, interp %p (epoch %" TCL_SIZE_MODIFIER "d)\n", - codePtr, codePtr->refCount, codePtr->compileEpoch, iPtr, iPtr->compileEpoch); + "ByteCode %p, refCt %" TCL_SIZE_MODIFIER "d, " + "epoch %" TCL_SIZE_MODIFIER "d, interp %p " + "(epoch %" TCL_SIZE_MODIFIER "d)\n", + codePtr, codePtr->refCount, codePtr->compileEpoch, iPtr, + iPtr->compileEpoch); Tcl_AppendToObj(bufferObj, " Source ", -1); PrintSourceToObj(bufferObj, codePtr->source, TclMin(codePtr->numSrcBytes, 55)); @@ -291,7 +295,10 @@ DisassembleByteCodeObj( TclGetString(fileObj), line); } Tcl_AppendPrintfToObj(bufferObj, - "\n Cmds %d, src %" TCL_SIZE_MODIFIER "d, inst %" TCL_SIZE_MODIFIER "d, litObjs %" TCL_SIZE_MODIFIER "d, aux %" TCL_SIZE_MODIFIER "d, stkDepth %" TCL_SIZE_MODIFIER "d, code/src %.2f\n", + "\n Cmds %d, src %" TCL_SIZE_MODIFIER "d, " + "inst %" TCL_SIZE_MODIFIER "d, litObjs %" TCL_SIZE_MODIFIER "d, " + "aux %" TCL_SIZE_MODIFIER "d, stkDepth %" TCL_SIZE_MODIFIER "d, " + "code/src %.2f\n", numCmds, codePtr->numSrcBytes, codePtr->numCodeBytes, codePtr->numLitObjects, codePtr->numAuxDataItems, codePtr->maxStackDepth, @@ -303,8 +310,10 @@ DisassembleByteCodeObj( #ifdef TCL_COMPILE_STATS Tcl_AppendPrintfToObj(bufferObj, - " Code %" TCL_Z_MODIFIER "u = header %" TCL_Z_MODIFIER "u+inst %" TCL_SIZE_MODIFIER "d+litObj %" - TCL_Z_MODIFIER "u+exc %" TCL_Z_MODIFIER "u+aux %" TCL_Z_MODIFIER "u+cmdMap %" TCL_SIZE_MODIFIER "d\n", + " Code %" TCL_Z_MODIFIER "u = header %" TCL_Z_MODIFIER "u+" + "inst %" TCL_SIZE_MODIFIER "d+litObj %" TCL_Z_MODIFIER "u+" + "exc %" TCL_Z_MODIFIER "u+aux %" TCL_Z_MODIFIER "u+" + "cmdMap %" TCL_SIZE_MODIFIER "d\n", codePtr->structureSize, offsetof(ByteCode, localCachePtr), codePtr->numCodeBytes, @@ -325,7 +334,9 @@ DisassembleByteCodeObj( Tcl_Size numCompiledLocals = procPtr->numCompiledLocals; Tcl_AppendPrintfToObj(bufferObj, - " Proc %p, refCt %" TCL_SIZE_MODIFIER "d, args %" TCL_SIZE_MODIFIER "d, compiled locals %" TCL_SIZE_MODIFIER "d\n", + " Proc %p, refCt %" TCL_SIZE_MODIFIER "d, " + "args %" TCL_SIZE_MODIFIER "d, " + "compiled locals %" TCL_SIZE_MODIFIER "d\n", procPtr, procPtr->refCount, procPtr->numArgs, numCompiledLocals); if (numCompiledLocals > 0) { @@ -356,24 +367,31 @@ DisassembleByteCodeObj( */ if ((int)codePtr->numExceptRanges > 0) { - Tcl_AppendPrintfToObj(bufferObj, " Exception ranges %" TCL_SIZE_MODIFIER "d, depth %" TCL_SIZE_MODIFIER "d:\n", + Tcl_AppendPrintfToObj(bufferObj, + " Exception ranges %" TCL_SIZE_MODIFIER "d, " + "depth %" TCL_SIZE_MODIFIER "d:\n", codePtr->numExceptRanges, codePtr->maxExceptDepth); for (i = 0; i < (int)codePtr->numExceptRanges; i++) { ExceptionRange *rangePtr = &codePtr->exceptArrayPtr[i]; Tcl_AppendPrintfToObj(bufferObj, - " %" TCL_SIZE_MODIFIER "d: level %" TCL_SIZE_MODIFIER "d, %s, pc %" TCL_SIZE_MODIFIER "d-%" TCL_SIZE_MODIFIER "d, ", + " %" TCL_SIZE_MODIFIER "d: " + "level %" TCL_SIZE_MODIFIER "d, %s, " + "pc %" TCL_SIZE_MODIFIER "d-%" TCL_SIZE_MODIFIER "d, ", i, rangePtr->nestingLevel, (rangePtr->type==LOOP_EXCEPTION_RANGE ? "loop" : "catch"), rangePtr->codeOffset, (rangePtr->codeOffset + rangePtr->numCodeBytes - 1)); switch (rangePtr->type) { case LOOP_EXCEPTION_RANGE: - Tcl_AppendPrintfToObj(bufferObj, "continue %" TCL_SIZE_MODIFIER "d, break %" TCL_SIZE_MODIFIER "d\n", + Tcl_AppendPrintfToObj(bufferObj, + "continue %" TCL_SIZE_MODIFIER "d, " + "break %" TCL_SIZE_MODIFIER "d\n", rangePtr->continueOffset, rangePtr->breakOffset); break; case CATCH_EXCEPTION_RANGE: - Tcl_AppendPrintfToObj(bufferObj, "catch %" TCL_SIZE_MODIFIER "d\n", + Tcl_AppendPrintfToObj(bufferObj, + "catch %" TCL_SIZE_MODIFIER "d\n", rangePtr->catchOffset); break; default: @@ -447,7 +465,8 @@ DisassembleByteCodeObj( srcLengthNext++; } - Tcl_AppendPrintfToObj(bufferObj, "%s%4" TCL_SIZE_MODIFIER "d: pc %d-%d, src %d-%d", + Tcl_AppendPrintfToObj(bufferObj, + "%s%4" TCL_SIZE_MODIFIER "d: pc %d-%d, src %d-%d", ((i % 2)? " " : "\n "), (i+1), codeOffset, (codeOffset + codeLen - 1), srcOffset, (srcOffset + srcLen - 1)); @@ -559,56 +578,69 @@ FormatInstruction( for (i = 0; i < instDesc->numOperands; i++) { switch (instDesc->opTypes[i]) { case OPERAND_INT1: - opnd = TclGetInt1AtPtr(pc+numBytes); numBytes++; + opnd = TclGetInt1AtPtr(pc+numBytes); + numBytes++; Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd); break; case OPERAND_INT4: - opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4; + opnd = TclGetInt4AtPtr(pc+numBytes); + numBytes += 4; Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd); break; case OPERAND_UINT1: - opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++; + opnd = TclGetUInt1AtPtr(pc+numBytes); + numBytes++; Tcl_AppendPrintfToObj(bufferObj, "%u ", opnd); break; case OPERAND_UINT4: - opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4; + opnd = TclGetUInt4AtPtr(pc+numBytes); + numBytes += 4; if (opCode == INST_START_CMD) { - snprintf(suffixBuffer+strlen(suffixBuffer), sizeof(suffixBuffer) - strlen(suffixBuffer), + snprintf(suffixBuffer+strlen(suffixBuffer), + sizeof(suffixBuffer) - strlen(suffixBuffer), ", %u cmds start here", opnd); } Tcl_AppendPrintfToObj(bufferObj, "%u ", opnd); break; case OPERAND_OFFSET1: - opnd = TclGetInt1AtPtr(pc+numBytes); numBytes++; + opnd = TclGetInt1AtPtr(pc+numBytes); + numBytes++; snprintf(suffixBuffer, sizeof(suffixBuffer), "pc %u", pcOffset+opnd); Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd); break; case OPERAND_OFFSET4: - opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4; + opnd = TclGetInt4AtPtr(pc+numBytes); + numBytes += 4; if (opCode == INST_START_CMD) { - snprintf(suffixBuffer, sizeof(suffixBuffer), "next cmd at pc %u", pcOffset+opnd); + snprintf(suffixBuffer, sizeof(suffixBuffer), + "next cmd at pc %u", pcOffset+opnd); } else { - snprintf(suffixBuffer, sizeof(suffixBuffer), "pc %u", pcOffset+opnd); + snprintf(suffixBuffer, sizeof(suffixBuffer), + "pc %u", pcOffset+opnd); } Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd); break; case OPERAND_LIT1: - opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++; + opnd = TclGetUInt1AtPtr(pc+numBytes); + numBytes++; suffixObj = codePtr->objArrayPtr[opnd]; Tcl_AppendPrintfToObj(bufferObj, "%u ", opnd); break; case OPERAND_LIT4: - opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4; + opnd = TclGetUInt4AtPtr(pc+numBytes); + numBytes += 4; suffixObj = codePtr->objArrayPtr[opnd]; Tcl_AppendPrintfToObj(bufferObj, "%u ", opnd); break; case OPERAND_AUX4: - opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4; + opnd = TclGetUInt4AtPtr(pc+numBytes); + numBytes += 4; Tcl_AppendPrintfToObj(bufferObj, "%u ", opnd); auxPtr = &codePtr->auxDataArrayPtr[opnd]; break; case OPERAND_IDX4: - opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4; + opnd = TclGetInt4AtPtr(pc+numBytes); + numBytes += 4; if (opnd >= -1) { Tcl_AppendPrintfToObj(bufferObj, "%d ", opnd); } else if (opnd == -2) { @@ -627,14 +659,16 @@ FormatInstruction( printLVTindex: if (localPtr != NULL) { if (opnd >= localCt) { - Tcl_Panic("FormatInstruction: bad local var index %u (%" TCL_SIZE_MODIFIER "d locals)", + Tcl_Panic("FormatInstruction: bad local var index %u " + "(%" TCL_SIZE_MODIFIER "d locals)", opnd, localCt); } for (j = 0; j < opnd; j++) { localPtr = localPtr->nextPtr; } if (TclIsVarTemporary(localPtr)) { - snprintf(suffixBuffer, sizeof(suffixBuffer), "temp var %u", opnd); + snprintf(suffixBuffer, sizeof(suffixBuffer), + "temp var %u", opnd); } else { snprintf(suffixBuffer, sizeof(suffixBuffer), "var "); suffixSrc = localPtr->name; @@ -643,10 +677,57 @@ FormatInstruction( Tcl_AppendPrintfToObj(bufferObj, "%%v%u ", opnd); break; case OPERAND_SCLS1: - opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++; + opnd = TclGetUInt1AtPtr(pc+numBytes); + numBytes++; Tcl_AppendPrintfToObj(bufferObj, "%s ", tclStringClassTable[opnd].name); break; + case OPERAND_UNSF1: + opnd = TclGetUInt1AtPtr(pc+numBytes); + numBytes++; + Tcl_AppendPrintfToObj(bufferObj, "silent=%s ", opnd?"no":"yes"); + break; + case OPERAND_CLK1: + opnd = TclGetUInt1AtPtr(pc+numBytes); + numBytes++; + switch (opnd) { + case CLOCK_READ_CLICKS: + Tcl_AppendPrintfToObj(bufferObj, "clicks " ); + break; + case CLOCK_READ_MICROS: + Tcl_AppendPrintfToObj(bufferObj, "micros " ); + break; + case CLOCK_READ_MILLIS: + Tcl_AppendPrintfToObj(bufferObj, "millis " ); + break; + case CLOCK_READ_SECS: + Tcl_AppendPrintfToObj(bufferObj, "secs " ); + break; + default: + Tcl_Panic("unknown clock type"); + } + break; + case OPERAND_LRPL1: + opnd = TclGetUInt1AtPtr(pc+numBytes); + numBytes++; + switch (opnd) { + case 0: + Tcl_AppendPrintfToObj(bufferObj, "0 "); + break; + case TCL_LREPLACE_END_IS_LAST: + Tcl_AppendPrintfToObj(bufferObj, "endLast "); + break; + case TCL_LREPLACE_SINGLE_INDEX: + Tcl_AppendPrintfToObj(bufferObj, "singleIdx "); + break; + case TCL_LREPLACE_END_IS_LAST | TCL_LREPLACE_NEED_IN_RANGE: + Tcl_AppendPrintfToObj(bufferObj, "endLast,indexTest "); + break; + default: + Tcl_AppendPrintfToObj(bufferObj, "endLast,singleIdx "); + break; + } + break; case OPERAND_NONE: default: break; @@ -746,13 +827,15 @@ TclGetInnerContext( objc = 2; break; - case INST_INVOKE_STK4: - objc = TclGetUInt4AtPtr(pc+1); + case INST_INVOKE_STK: + objc = TclGetUInt4AtPtr(pc + 1); break; +#ifndef REMOVE_DEPRECATED_OPCODES case INST_INVOKE_STK1: - objc = TclGetUInt1AtPtr(pc+1); + objc = TclGetUInt1AtPtr(pc + 1); break; +#endif } result = iPtr->innerContext; @@ -1026,6 +1109,9 @@ DisassembleByteCodeAsDicts( val = TclGetInt1AtPtr(opnd); opnd += 1; goto formatNumber; + case OPERAND_UNSF1: // TODO: decode + case OPERAND_CLK1: // TODO: decode + case OPERAND_LRPL1: // TODO: decode case OPERAND_UINT1: val = TclGetUInt1AtPtr(opnd); opnd += 1; @@ -1148,14 +1234,19 @@ DisassembleByteCodeAsDicts( switch (rangePtr->type) { case LOOP_EXCEPTION_RANGE: Tcl_ListObjAppendElement(NULL, exn, Tcl_ObjPrintf( - "type %s level %" TCL_SIZE_MODIFIER "d from %" TCL_SIZE_MODIFIER "d to %" TCL_SIZE_MODIFIER "d break %" TCL_SIZE_MODIFIER "d continue %" TCL_SIZE_MODIFIER "d", + "type %s level %" TCL_SIZE_MODIFIER "d " + "from %" TCL_SIZE_MODIFIER "d to %" TCL_SIZE_MODIFIER "d " + "break %" TCL_SIZE_MODIFIER "d " + "continue %" TCL_SIZE_MODIFIER "d", "loop", rangePtr->nestingLevel, rangePtr->codeOffset, rangePtr->codeOffset + rangePtr->numCodeBytes - 1, rangePtr->breakOffset, rangePtr->continueOffset)); break; case CATCH_EXCEPTION_RANGE: Tcl_ListObjAppendElement(NULL, exn, Tcl_ObjPrintf( - "type %s level %" TCL_SIZE_MODIFIER "d from %" TCL_SIZE_MODIFIER "d to %" TCL_SIZE_MODIFIER "d catch %" TCL_SIZE_MODIFIER "d", + "type %s level %" TCL_SIZE_MODIFIER "d " + "from %" TCL_SIZE_MODIFIER "d to %" TCL_SIZE_MODIFIER "d " + "catch %" TCL_SIZE_MODIFIER "d", "catch", rangePtr->nestingLevel, rangePtr->codeOffset, rangePtr->codeOffset + rangePtr->numCodeBytes - 1, rangePtr->catchOffset)); @@ -1279,9 +1370,12 @@ Tcl_DisassembleObjCmd( Tcl_Obj *codeObjPtr = NULL; Proc *procPtr = NULL; Tcl_HashEntry *hPtr; + Tcl_Obj *ooWhat = NULL; Object *oPtr; + Class *classPtr; ByteCode *codePtr; Method *methodPtr; + const char *bodyType; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "type ..."); @@ -1379,23 +1473,17 @@ Tcl_DisassembleObjCmd( * Look up the body of a constructor. */ - oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]); - if (oPtr == NULL) { - return TCL_ERROR; - } - if (oPtr->classPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "\"%s\" is not a class", TclGetString(objv[2]))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", - TclGetString(objv[2]), (char *)NULL); + ooWhat = objv[2]; + classPtr = TclOOGetClassFromObj(interp, ooWhat); + if (classPtr == NULL) { return TCL_ERROR; } - methodPtr = oPtr->classPtr->constructorPtr; + methodPtr = classPtr->constructorPtr; if (methodPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "\"%s\" has no defined constructor", - TclGetString(objv[2]))); + TclGetString(ooWhat))); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", "CONSRUCTOR", (char *)NULL); return TCL_ERROR; @@ -1409,30 +1497,9 @@ Tcl_DisassembleObjCmd( return TCL_ERROR; } - /* - * Compile if necessary. - */ - - if (!TclHasInternalRep(procPtr->bodyPtr, &tclByteCodeType)) { - Command cmd; - - /* - * Yes, this is ugly, but we need to pass the namespace in to the - * compiler in two places. - */ - - cmd.nsPtr = (Namespace *) oPtr->namespacePtr; - procPtr->cmdPtr = &cmd; - result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr, - (Namespace *) oPtr->namespacePtr, "body of constructor", - TclGetString(objv[2])); - procPtr->cmdPtr = NULL; - if (result != TCL_OK) { - return result; - } - } - codeObjPtr = procPtr->bodyPtr; - break; + oPtr = classPtr->thisPtr; + bodyType = "body of constructor"; + goto compileMethodIfNeeded; case DISAS_CLASS_DESTRUCTOR: if (objc != 3) { @@ -1444,23 +1511,17 @@ Tcl_DisassembleObjCmd( * Look up the body of a destructor. */ - oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]); - if (oPtr == NULL) { - return TCL_ERROR; - } - if (oPtr->classPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "\"%s\" is not a class", TclGetString(objv[2]))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", - TclGetString(objv[2]), (char *)NULL); + ooWhat = objv[2]; + classPtr = TclOOGetClassFromObj(interp, ooWhat); + if (classPtr == NULL) { return TCL_ERROR; } - methodPtr = oPtr->classPtr->destructorPtr; + methodPtr = classPtr->destructorPtr; if (methodPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "\"%s\" has no defined destructor", - TclGetString(objv[2]))); + TclGetString(ooWhat))); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", "DESRUCTOR", (char *)NULL); return TCL_ERROR; @@ -1474,30 +1535,9 @@ Tcl_DisassembleObjCmd( return TCL_ERROR; } - /* - * Compile if necessary. - */ - - if (!TclHasInternalRep(procPtr->bodyPtr, &tclByteCodeType)) { - Command cmd; - - /* - * Yes, this is ugly, but we need to pass the namespace in to the - * compiler in two places. - */ - - cmd.nsPtr = (Namespace *) oPtr->namespacePtr; - procPtr->cmdPtr = &cmd; - result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr, - (Namespace *) oPtr->namespacePtr, "body of destructor", - TclGetString(objv[2])); - procPtr->cmdPtr = NULL; - if (result != TCL_OK) { - return result; - } - } - codeObjPtr = procPtr->bodyPtr; - break; + oPtr = classPtr->thisPtr; + bodyType = "body of destructor"; + goto compileMethodIfNeeded; case DISAS_CLASS_METHOD: if (objc != 4) { @@ -1509,19 +1549,13 @@ Tcl_DisassembleObjCmd( * Look up the body of a class method. */ - oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]); - if (oPtr == NULL) { - return TCL_ERROR; - } - if (oPtr->classPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "\"%s\" is not a class", TclGetString(objv[2]))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", - TclGetString(objv[2]), (char *)NULL); + ooWhat = objv[3]; + classPtr = TclOOGetClassFromObj(interp, objv[2]); + if (classPtr == NULL) { return TCL_ERROR; } - hPtr = Tcl_FindHashEntry(&oPtr->classPtr->classMethods, - objv[3]); + oPtr = classPtr->thisPtr; + hPtr = Tcl_FindHashEntry(&classPtr->classMethods, ooWhat); goto methodBody; case DISAS_OBJECT_METHOD: if (objc != 4) { @@ -1533,14 +1567,16 @@ Tcl_DisassembleObjCmd( * Look up the body of an instance method. */ + ooWhat = objv[3]; oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]); if (oPtr == NULL) { return TCL_ERROR; } + ooWhat = objv[3]; if (oPtr->methodsPtr == NULL) { goto unknownMethod; } - hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, objv[3]); + hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, ooWhat); /* * Compile (if necessary) and disassemble a method body. @@ -1550,9 +1586,9 @@ Tcl_DisassembleObjCmd( if (hPtr == NULL) { unknownMethod: Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "unknown method \"%s\"", TclGetString(objv[3]))); + "unknown method \"%s\"", TclGetString(ooWhat))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", - TclGetString(objv[3]), (char *)NULL); + TclGetString(ooWhat), (char *)NULL); return TCL_ERROR; } procPtr = TclOOGetProcFromMethod((Method *)Tcl_GetHashValue(hPtr)); @@ -1563,6 +1599,9 @@ Tcl_DisassembleObjCmd( "METHODTYPE", (char *)NULL); return TCL_ERROR; } + bodyType = "body of method"; + + compileMethodIfNeeded: if (!TclHasInternalRep(procPtr->bodyPtr, &tclByteCodeType)) { Command cmd; @@ -1574,8 +1613,8 @@ Tcl_DisassembleObjCmd( cmd.nsPtr = (Namespace *) oPtr->namespacePtr; procPtr->cmdPtr = &cmd; result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr, - (Namespace *) oPtr->namespacePtr, "body of method", - TclGetString(objv[3])); + (Namespace *) oPtr->namespacePtr, bodyType, + TclGetString(ooWhat)); procPtr->cmdPtr = NULL; if (result != TCL_OK) { return result; @@ -1584,7 +1623,7 @@ Tcl_DisassembleObjCmd( codeObjPtr = procPtr->bodyPtr; break; default: - CLANG_ASSERT(0); + TCL_UNREACHABLE(); } /* diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index cbd2dc0..00cd044 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -881,7 +881,7 @@ Tcl_GetEncodingNames( Tcl_HashEntry *hPtr; Tcl_Obj *map, *name, *result; Tcl_DictSearch mapSearch; - int dummy, done = 0; + int done = 0; TclNewObj(result); Tcl_InitObjHashTable(&table); @@ -896,7 +896,7 @@ Tcl_GetEncodingNames( Encoding *encodingPtr = (Encoding *)Tcl_GetHashValue(hPtr); Tcl_CreateHashEntry(&table, - Tcl_NewStringObj(encodingPtr->name, TCL_INDEX_NONE), &dummy); + Tcl_NewStringObj(encodingPtr->name, TCL_INDEX_NONE), NULL); } Tcl_MutexUnlock(&encodingMutex); @@ -909,7 +909,7 @@ Tcl_GetEncodingNames( Tcl_DictObjFirst(NULL, map, &mapSearch, &name, NULL, &done); for (; !done; Tcl_DictObjNext(&mapSearch, &name, NULL, &done)) { - Tcl_CreateHashEntry(&table, name, &dummy); + Tcl_CreateHashEntry(&table, name, NULL); } /* @@ -1964,22 +1964,22 @@ LoadTableEncoding( */ static const char staticHex[] = { - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 0 ... 15 */ - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 16 ... 31 */ - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 32 ... 47 */ - 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 0, 0, 0, 0, 0, 0, /* 48 ... 63 */ - 0, 10, 11, 12, 13, 14, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 64 ... 79 */ - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 80 ... 95 */ - 0, 10, 11, 12, 13, 14, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 96 ... 111 */ - 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 0, 0, 0, 0, 0, 0, /* 112 ... 127 */ - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 128 ... 143 */ - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 144 ... 159 */ - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 160 ... 175 */ - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 176 ... 191 */ - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 192 ... 207 */ - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 208 ... 223 */ - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 224 ... 239 */ - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 240 ... 255 */ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 0 ... 15 */ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 16 ... 31 */ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 32 ... 47 */ + 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 0, 0, 0, 0, 0, 0, /* 48 ... 63 */ + 0, 10, 11, 12, 13, 14, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 64 ... 79 */ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 80 ... 95 */ + 0, 10, 11, 12, 13, 14, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 96 ... 111 */ + 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 0, 0, 0, 0, 0, 0, /* 112 ... 127 */ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 128 ... 143 */ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 144 ... 159 */ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 160 ... 175 */ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 176 ... 191 */ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 192 ... 207 */ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 208 ... 223 */ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 224 ... 239 */ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 240 ... 255 */ }; Tcl_DStringInit(&lineString); @@ -2492,19 +2492,19 @@ UtfToUtfProc( * by a low surrogate. NOT to be called for strict profile since * that should raise an error. */ -#define OUTPUT_ISOLATEDSURROGATE \ - do { \ - Tcl_UniChar high; \ - if (PROFILE_REPLACE(profile)) { \ - high = UNICODE_REPLACE_CHAR; \ - } else { \ - high = (Tcl_UniChar)(ptrdiff_t) *statePtr; \ - } \ - assert(!(flags & ENCODING_UTF)); /* Must be CESU-8 */ \ - assert(HIGH_SURROGATE(high)); \ - assert(!PROFILE_STRICT(profile)); \ - dst += Tcl_UniCharToUtf(high, dst); \ - *statePtr = 0; /* Reset state */ \ +#define OUTPUT_ISOLATEDSURROGATE() \ + do { \ + Tcl_UniChar high; \ + if (PROFILE_REPLACE(profile)) { \ + high = UNICODE_REPLACE_CHAR; \ + } else { \ + high = (Tcl_UniChar)(ptrdiff_t) *statePtr; \ + } \ + assert(!(flags & ENCODING_UTF)); /* Must be CESU-8 */ \ + assert(HIGH_SURROGATE(high)); \ + assert(!PROFILE_STRICT(profile)); \ + dst += Tcl_UniCharToUtf(high, dst); \ + *statePtr = 0; /* Reset state */ \ } while (0) /* @@ -2512,20 +2512,19 @@ UtfToUtfProc( * an error if profile is strict, or output an appropriate * character for replace and tcl8 profiles and continue. */ -#define CHECK_ISOLATEDSURROGATE \ - if (*statePtr) { \ - if (PROFILE_STRICT(profile)) { \ - result = TCL_CONVERT_SYNTAX; \ - break; \ - } \ - OUTPUT_ISOLATEDSURROGATE; \ - continue; /* Rerun loop so length checks etc. repeated */ \ - } else \ +#define CHECK_ISOLATEDSURROGATE() \ + if (*statePtr) { \ + if (PROFILE_STRICT(profile)) { \ + result = TCL_CONVERT_SYNTAX; \ + break; \ + } \ + OUTPUT_ISOLATEDSURROGATE(); \ + continue; /* Rerun loop so length checks etc. repeated */ \ + } else \ (void) 0 profile = ENCODING_PROFILE_GET(flags); for (numChars = 0; src < srcEnd && numChars <= charLimit; numChars++) { - if ((src > srcClose) && (!Tcl_UtfCharComplete(src, srcEnd - src))) { /* * If there is more string to follow, this will ensure that the @@ -2540,19 +2539,18 @@ UtfToUtfProc( break; } if (UCHAR(*src) < 0x80 && !((UCHAR(*src) == 0) && (flags & ENCODING_INPUT))) { - - CHECK_ISOLATEDSURROGATE; + CHECK_ISOLATEDSURROGATE(); /* * Copy 7bit characters, but skip null-bytes when we are in input * mode, so that they get converted to \xC0\x80. */ *dst++ = *src++; } else if ((UCHAR(*src) == 0xC0) && (src + 1 < srcEnd) && - (UCHAR(src[1]) == 0x80) && - (!(flags & ENCODING_INPUT) || !PROFILE_TCL8(profile))) { + (UCHAR(src[1]) == 0x80) && + (!(flags & ENCODING_INPUT) || !PROFILE_TCL8(profile))) { /* Special sequence \xC0\x80 */ - CHECK_ISOLATEDSURROGATE; + CHECK_ISOLATEDSURROGATE(); if (!PROFILE_TCL8(profile) && (flags & ENCODING_INPUT)) { if (PROFILE_REPLACE(profile)) { dst += Tcl_UniCharToUtf(UNICODE_REPLACE_CHAR, dst); @@ -2578,7 +2576,7 @@ UtfToUtfProc( * because the UTF-8 sequence is truncated. */ - CHECK_ISOLATEDSURROGATE; + CHECK_ISOLATEDSURROGATE(); if (flags & ENCODING_INPUT) { /* Incomplete bytes for modified UTF-8 target */ @@ -2622,8 +2620,8 @@ UtfToUtfProc( src += len; if (!(flags & ENCODING_UTF) && !(flags & ENCODING_INPUT) && (ch > 0x7FF)) { - assert(savedSurrogate == 0); /* Since this flag combo - will never set *statePtr */ + assert(savedSurrogate == 0); /* Since this flag combo + * will never set *statePtr */ if (ch > 0xFFFF) { /* CESU-8 6-byte sequence for chars > U+FFFF */ ch -= 0x10000; @@ -2641,7 +2639,7 @@ UtfToUtfProc( /* UTF-8, not CESU-8, so surrogates should not appear */ if (PROFILE_STRICT(profile)) { result = (flags & ENCODING_INPUT) - ? TCL_CONVERT_SYNTAX : TCL_CONVERT_UNKNOWN; + ? TCL_CONVERT_SYNTAX : TCL_CONVERT_UNKNOWN; src = saveSrc; break; } else if (PROFILE_REPLACE(profile)) { @@ -2659,7 +2657,7 @@ UtfToUtfProc( /* Isolated low surrogate */ if (PROFILE_STRICT(profile)) { result = (flags & ENCODING_INPUT) - ? TCL_CONVERT_SYNTAX : TCL_CONVERT_UNKNOWN; + ? TCL_CONVERT_SYNTAX : TCL_CONVERT_UNKNOWN; src = saveSrc; break; } else if (PROFILE_REPLACE(profile)) { @@ -2676,7 +2674,7 @@ UtfToUtfProc( assert(HIGH_SURROGATE(savedSurrogate)); if (PROFILE_STRICT(profile)) { result = (flags & ENCODING_INPUT) - ? TCL_CONVERT_SYNTAX : TCL_CONVERT_UNKNOWN; + ? TCL_CONVERT_SYNTAX : TCL_CONVERT_UNKNOWN; src = saveSrc; break; } else if (PROFILE_REPLACE(profile)) { @@ -2694,7 +2692,7 @@ UtfToUtfProc( } } else { /* Normal character */ - CHECK_ISOLATEDSURROGATE; + CHECK_ISOLATEDSURROGATE(); } dst += Tcl_UniCharToUtf(ch, dst); @@ -2710,7 +2708,7 @@ UtfToUtfProc( /* No more data coming */ if (PROFILE_STRICT(profile)) { result = (flags & ENCODING_INPUT) - ? TCL_CONVERT_SYNTAX : TCL_CONVERT_UNKNOWN; + ? TCL_CONVERT_SYNTAX : TCL_CONVERT_UNKNOWN; } else { if (PROFILE_REPLACE(profile)) { ch = UNICODE_REPLACE_CHAR; @@ -3069,7 +3067,7 @@ Utf16ToUtfProc( if (PROFILE_STRICT(flags)) { result = TCL_CONVERT_SYNTAX; src -= 2; /* Go back to beginning of high surrogate */ - dst--; /* Also undo writing a single byte too much */ + dst--; /* Also undo writing a single byte too much */ break; } if (PROFILE_REPLACE(flags)) { diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index cf4e18f..a4d2532 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -24,7 +24,7 @@ static int ReadOneEnsembleOption(Tcl_Interp *interp, static int ReadAllEnsembleOptions(Tcl_Interp *interp, Tcl_Command token); static int SetEnsembleConfigOptions(Tcl_Interp *interp, - Tcl_Command token, int objc, + Tcl_Command token, Tcl_Size objc, Tcl_Obj *const objv[]); static inline int EnsembleUnknownCallback(Tcl_Interp *interp, EnsembleConfig *ensemblePtr, int objc, @@ -588,7 +588,7 @@ static int SetEnsembleConfigOptions( Tcl_Interp *interp, Tcl_Command token, /* The ensemble to configure. */ - int objc, /* The count of option-related arguments. */ + Tcl_Size objc, /* The count of option-related arguments. */ Tcl_Obj *const objv[]) /* Option-related arguments. */ { Tcl_Size len; @@ -1583,7 +1583,8 @@ TclMakeEnsemble( const char **nameParts = NULL; const char *cmdName = NULL; Tcl_Size i, nameCount = 0; - int ensembleFlags = 0, hiddenLen; + int ensembleFlags = 0; + Tcl_Size hiddenLen; /* * Construct the path for the ensemble namespace and create it. @@ -2748,7 +2749,7 @@ BuildEnsembleConfig( while (!done) { const char *name = TclGetString(keyObj); - hPtr = Tcl_CreateHashEntry(hash, name, &isNew); + hPtr = Tcl_CreateHashEntry(hash, name, NULL); Tcl_SetHashValue(hPtr, valueObj); Tcl_IncrRefCount(valueObj); Tcl_DictObjNext(&dictSearch, &keyObj, &valueObj, &done); @@ -3259,18 +3260,7 @@ TclCompileEnsemble( * Throw out any line information generated by the failed compile attempt. */ - while (mapPtr->nuloc > eclIndex + 1) { - mapPtr->nuloc--; - Tcl_Free(mapPtr->loc[mapPtr->nuloc].line); - mapPtr->loc[mapPtr->nuloc].line = NULL; - } - - /* - * Reset the index of next command. Toss out any from failed nested - * partial compiles. - */ - - envPtr->numCommands = mapPtr->nuloc; + ClearFailedCompile(envPtr); /* * Failed to do a full compile for some reason. Try to do a direct invoke @@ -3330,7 +3320,7 @@ TclAttemptCompileProc( Tcl_Size i; Tcl_Token *saveTokenPtr = parsePtr->tokenPtr; Tcl_Size savedStackDepth = envPtr->currStackDepth; - Tcl_Size savedCodeNext = envPtr->codeNext - envPtr->codeStart; + Tcl_Size savedCodeNext = CurrentOffset(envPtr); Tcl_Size savedAuxDataArrayNext = envPtr->auxDataArrayNext; Tcl_Size savedExceptArrayNext = envPtr->exceptArrayNext; #ifdef TCL_COMPILE_DEBUG @@ -3358,8 +3348,8 @@ TclAttemptCompileProc( * index values. */ - mapPtr->loc[eclIndex].line += (depth - 1); - mapPtr->loc[eclIndex].next += (depth - 1); + ExtCmdLocation.line += (depth - 1); + ExtCmdLocation.next += (depth - 1); /* * Hand off compilation to the subcommand compiler. At last! @@ -3371,8 +3361,8 @@ TclAttemptCompileProc( * Undo the shift. */ - mapPtr->loc[eclIndex].line -= (depth - 1); - mapPtr->loc[eclIndex].next -= (depth - 1); + ExtCmdLocation.line -= (depth - 1); + ExtCmdLocation.next -= (depth - 1); parsePtr->numWords += (depth - 1); parsePtr->tokenPtr = saveTokenPtr; @@ -3462,9 +3452,8 @@ CompileToInvokedCommand( DefineLineInformation; Tcl_Token *tokPtr; Tcl_Obj *objPtr, **words; - const char *bytes; int cmdLit, extraLiteralFlags = LITERAL_CMD_NAME; - Tcl_Size i, numWords, length; + Tcl_Size i, numWords; /* * Push the words of the command. Take care; the command words may be @@ -3476,15 +3465,13 @@ CompileToInvokedCommand( for (i = 0, tokPtr = parsePtr->tokenPtr; i < parsePtr->numWords; i++, tokPtr = TokenAfter(tokPtr)) { if (i > 0 && i <= numWords) { - bytes = TclGetStringFromObj(words[i - 1], &length); - PushLiteral(envPtr, bytes, length); + PUSH_OBJ( words[i - 1]); continue; } SetLineInformation(i); if (tokPtr->type == TCL_TOKEN_SIMPLE_WORD) { - int literal = TclRegisterLiteral(envPtr, - tokPtr[1].start, tokPtr[1].size, 0); + int literal = PUSH_SIMPLE_TOKEN(tokPtr); if (envPtr->clNext) { TclContinuationsEnterDerived( @@ -3492,7 +3479,6 @@ CompileToInvokedCommand( tokPtr[1].start - envPtr->source, envPtr->clNext); } - TclEmitPush(literal, envPtr); } else { CompileTokens(envPtr, tokPtr, interp); } @@ -3505,21 +3491,17 @@ CompileToInvokedCommand( TclNewObj(objPtr); Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr); - bytes = TclGetStringFromObj(objPtr, &length); if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_VIA_RESOLVER)) { extraLiteralFlags |= LITERAL_UNSHARED; } - cmdLit = TclRegisterLiteral(envPtr, bytes, length, extraLiteralFlags); + cmdLit = PUSH_OBJ_FLAGS(objPtr, extraLiteralFlags); TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLit), cmdPtr); - TclEmitPush(cmdLit, envPtr); - TclDecrRefCount(objPtr); /* * Do the replacing dispatch. */ - TclEmitInvoke(envPtr, INST_INVOKE_REPLACE, parsePtr->numWords, - numWords + 1); + INVOKE41( INVOKE_REPLACE, parsePtr->numWords, numWords+1); } /* diff --git a/generic/tclEnv.c b/generic/tclEnv.c index 0128672..98e7317 100644 --- a/generic/tclEnv.c +++ b/generic/tclEnv.c @@ -45,7 +45,7 @@ static struct { char **cache; /* Array containing all of the environment * strings that Tcl has allocated. */ #ifndef USE_PUTENV - techar **ourEnviron; /* Cache of the array that we allocate. We + techar **ourEnviron; /* Cache of the array that we allocate. We * need to track this in case another * subsystem swaps around the environ array * like we do. */ diff --git a/generic/tclEvent.c b/generic/tclEvent.c index d991d66..5f08424 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -36,6 +36,13 @@ typedef struct BgError { } BgError; /* + * The assoc data key used in this file. The data associated with it is a + * reference to an ErrAssocData structure, and will be deallocated with + * BgErrorDeleteProc at the appropriate time. + */ +#define ASSOC_KEY "tclBgError" + +/* * One of the structures below is associated with the "tclBgError" assoc data * for each interpreter. It keeps track of the head and tail of the list of * pending background errors for the interpreter. @@ -72,7 +79,7 @@ typedef struct { typedef struct ExitHandler { Tcl_ExitProc *proc; /* Function to call when process exits. */ - void *clientData; /* One word of information to pass to proc. */ + void *clientData; /* One word of information to pass to proc. */ struct ExitHandler *nextPtr;/* Next in list of all exit handlers for this * application, or NULL for end of list. */ } ExitHandler; @@ -122,7 +129,7 @@ static Tcl_ThreadDataKey dataKey; #if TCL_THREADS typedef struct { Tcl_ThreadCreateProc *proc; /* Main() function of the thread */ - void *clientData; /* The one argument to Main() */ + void *clientData; /* The one argument to Main() */ } ThreadClientData; static Tcl_ThreadCreateType NewThreadProc(void *clientData); #endif /* TCL_THREADS */ @@ -182,7 +189,7 @@ Tcl_BackgroundException( errPtr->nextPtr = NULL; (void) TclGetBgErrorHandler(interp); - assocPtr = (ErrAssocData *)Tcl_GetAssocData(interp, "tclBgError", NULL); + assocPtr = (ErrAssocData *)Tcl_GetAssocData(interp, ASSOC_KEY, NULL); if (assocPtr->firstBgPtr == NULL) { assocPtr->firstBgPtr = errPtr; Tcl_DoWhenIdle(HandleBgErrors, assocPtr); @@ -212,7 +219,7 @@ Tcl_BackgroundException( static void HandleBgErrors( - void *clientData) /* Pointer to ErrAssocData structure. */ + void *clientData) /* Pointer to ErrAssocData structure. */ { ErrAssocData *assocPtr = (ErrAssocData *)clientData; Tcl_Interp *interp = assocPtr->interp; @@ -522,7 +529,7 @@ TclSetBgErrorHandler( Tcl_Interp *interp, Tcl_Obj *cmdPrefix) { - ErrAssocData *assocPtr = (ErrAssocData *)Tcl_GetAssocData(interp, "tclBgError", NULL); + ErrAssocData *assocPtr = (ErrAssocData *)Tcl_GetAssocData(interp, ASSOC_KEY, NULL); if (cmdPrefix == NULL) { Tcl_Panic("TclSetBgErrorHandler: NULL cmdPrefix argument"); @@ -537,7 +544,7 @@ TclSetBgErrorHandler( assocPtr->cmdPrefix = NULL; assocPtr->firstBgPtr = NULL; assocPtr->lastBgPtr = NULL; - Tcl_SetAssocData(interp, "tclBgError", BgErrorDeleteProc, assocPtr); + Tcl_SetAssocData(interp, ASSOC_KEY, BgErrorDeleteProc, assocPtr); } if (assocPtr->cmdPrefix) { Tcl_DecrRefCount(assocPtr->cmdPrefix); @@ -567,14 +574,14 @@ Tcl_Obj * TclGetBgErrorHandler( Tcl_Interp *interp) { - ErrAssocData *assocPtr = (ErrAssocData *)Tcl_GetAssocData(interp, "tclBgError", NULL); + ErrAssocData *assocPtr = (ErrAssocData *)Tcl_GetAssocData(interp, ASSOC_KEY, NULL); if (assocPtr == NULL) { Tcl_Obj *bgerrorObj; TclNewLiteralStringObj(bgerrorObj, "::tcl::Bgerror"); TclSetBgErrorHandler(interp, bgerrorObj); - assocPtr = (ErrAssocData *)Tcl_GetAssocData(interp, "tclBgError", NULL); + assocPtr = (ErrAssocData *)Tcl_GetAssocData(interp, ASSOC_KEY, NULL); } return assocPtr->cmdPrefix; } @@ -600,7 +607,7 @@ TclGetBgErrorHandler( static void BgErrorDeleteProc( - void *clientData, /* Pointer to ErrAssocData structure. */ + void *clientData, /* Pointer to ErrAssocData structure. */ TCL_UNUSED(Tcl_Interp *)) { ErrAssocData *assocPtr = (ErrAssocData *)clientData; @@ -639,7 +646,7 @@ BgErrorDeleteProc( void Tcl_CreateExitHandler( Tcl_ExitProc *proc, /* Function to invoke. */ - void *clientData) /* Arbitrary value to pass to proc. */ + void *clientData) /* Arbitrary value to pass to proc. */ { ExitHandler *exitPtr = (ExitHandler*)Tcl_Alloc(sizeof(ExitHandler)); @@ -672,7 +679,7 @@ Tcl_CreateExitHandler( void TclCreateLateExitHandler( Tcl_ExitProc *proc, /* Function to invoke. */ - void *clientData) /* Arbitrary value to pass to proc. */ + void *clientData) /* Arbitrary value to pass to proc. */ { ExitHandler *exitPtr = (ExitHandler*)Tcl_Alloc(sizeof(ExitHandler)); @@ -705,7 +712,7 @@ TclCreateLateExitHandler( void Tcl_DeleteExitHandler( Tcl_ExitProc *proc, /* Function that was previously registered. */ - void *clientData) /* Arbitrary value to pass to proc. */ + void *clientData) /* Arbitrary value to pass to proc. */ { ExitHandler *exitPtr, *prevPtr; @@ -748,7 +755,7 @@ Tcl_DeleteExitHandler( void TclDeleteLateExitHandler( Tcl_ExitProc *proc, /* Function that was previously registered. */ - void *clientData) /* Arbitrary value to pass to proc. */ + void *clientData) /* Arbitrary value to pass to proc. */ { ExitHandler *exitPtr, *prevPtr; @@ -791,7 +798,7 @@ TclDeleteLateExitHandler( void Tcl_CreateThreadExitHandler( Tcl_ExitProc *proc, /* Function to invoke. */ - void *clientData) /* Arbitrary value to pass to proc. */ + void *clientData) /* Arbitrary value to pass to proc. */ { ExitHandler *exitPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -824,7 +831,7 @@ Tcl_CreateThreadExitHandler( void Tcl_DeleteThreadExitHandler( Tcl_ExitProc *proc, /* Function that was previously registered. */ - void *clientData) /* Arbitrary value to pass to proc. */ + void *clientData) /* Arbitrary value to pass to proc. */ { ExitHandler *exitPtr, *prevPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -1727,7 +1734,7 @@ Tcl_VwaitObjCmd( foundEvent = 1; while (!timedOut && foundEvent && - ((!any && (done < numItems)) || (any && !done))) { + ((!any && (done < numItems)) || (any && !done))) { foundEvent = Tcl_DoOneEvent(mask); if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) { break; diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 37d5041..1b675d5 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -7,7 +7,7 @@ * Copyright © 1998-2000 Scriptics Corporation. * Copyright © 2001 Kevin B. Kenny. All rights reserved. * Copyright © 2002-2010 Miguel Sofer. - * Copyright © 2005-2007 Donal K. Fellows. + * Copyright © 2005-2025 Donal K. Fellows. * Copyright © 2007 Daniel A. Steffen <das@users.sourceforge.net> * Copyright © 2006-2008 Joe Mistachkin. All rights reserved. * @@ -16,12 +16,22 @@ */ #include "tclInt.h" +#ifndef REMOVE_DEPRECATED_OPCODES +/* If we're not removing them, stop the deprecated opcodes giving warnings. */ +#define ALLOW_DEPRECATED_OPCODES +#endif #include "tclCompile.h" #include "tclOOInt.h" #include "tclTomMath.h" #include <math.h> #include <assert.h> +#if defined(__GNUC__) && (__GNUC__ > 4) && defined(_WIN32) && defined(TCL_COMPILE_DEBUG) +// These are FAR too noisy when we're using the MSVC runtime. +#pragma GCC diagnostic ignored "-Wformat" +#pragma GCC diagnostic ignored "-Wformat-extra-args" +#endif + /* * Hack to determine whether we may expect IEEE floating point. The hack is * formally incorrect in that non-IEEE platforms might have the same precision @@ -64,7 +74,7 @@ static int cachedInExit = 0; * This variable is linked to the Tcl variable "tcl_traceExec". */ -int tclTraceExec = 0; +int tclTraceExec = TCL_TRACE_BYTECODE_EXEC_NONE; #endif /* @@ -114,37 +124,40 @@ typedef struct { Tcl_Obj **catchTop; /* These fields are used on return TO this */ Tcl_Obj *auxObjList; /* level: they record the state when a new */ CmdFrame cmdFrame; /* codePtr was received for NR execution. */ +#ifdef TCL_COMPILE_DEBUG + char cmdNameBuf[21]; /* Space to store the command name across an invoke. */ +#endif Tcl_Obj *stack[1]; /* Start of the actual combined catch and obj * stacks; the struct will be expanded as * necessary */ } TEBCdata; #define TEBC_YIELD() \ - do { \ - esPtr->tosPtr = tosPtr; \ - TclNRAddCallback(interp, TEBCresume, \ - TD, pc, INT2PTR(cleanup), NULL); \ + do { \ + esPtr->tosPtr = tosPtr; \ + TclNRAddCallback(interp, TEBCresume, \ + TD, pc, INT2PTR(cleanup), NULL); \ } while (0) #define TEBC_DATA_DIG() \ - do { \ - tosPtr = esPtr->tosPtr; \ + do { \ + tosPtr = esPtr->tosPtr; \ } while (0) #define PUSH_TAUX_OBJ(objPtr) \ - do { \ - if (auxObjList) { \ - (objPtr)->length += auxObjList->length; \ - } \ - (objPtr)->internalRep.twoPtrValue.ptr1 = auxObjList; \ - auxObjList = (objPtr); \ + do { \ + if (auxObjList) { \ + (objPtr)->length += auxObjList->length; \ + } \ + (objPtr)->internalRep.twoPtrValue.ptr1 = auxObjList; \ + auxObjList = (objPtr); \ } while (0) #define POP_TAUX_OBJ() \ - do { \ - tmpPtr = auxObjList; \ + do { \ + tmpPtr = auxObjList; \ auxObjList = (Tcl_Obj *)tmpPtr->internalRep.twoPtrValue.ptr1; \ - Tcl_DecrRefCount(tmpPtr); \ + Tcl_DecrRefCount(tmpPtr); \ } while (0) /* @@ -195,7 +208,7 @@ VarHashFindVar( } while (0) #else #define CHECK_STACK() -#endif +#endif // TCL_COMPILE_DEBUG #define NEXT_INST_F(pcAdjustment, nCleanup, resultHandling) \ do { \ @@ -219,18 +232,32 @@ VarHashFindVar( switch (nCleanup) { \ case 1: goto cleanup1_pushObjResultPtr; \ case 2: goto cleanup2_pushObjResultPtr; \ - case 0: break; \ + default: TCL_UNREACHABLE(); \ } \ } else { \ pc += (pcAdjustment); \ switch (nCleanup) { \ case 1: goto cleanup1; \ case 2: goto cleanup2; \ - case 0: break; \ + default: TCL_UNREACHABLE(); \ } \ } \ } while (0) +/* Cut down version of NEXT_INST_F() for resultHandling==0 case. */ +#define NEXT_INST_F0(pcAdjustment, nCleanup) \ + do { \ + TCL_CT_ASSERT((nCleanup >= 0) && (nCleanup <= 2)); \ + CHECK_STACK(); \ + pc += (pcAdjustment); \ + switch (nCleanup) { \ + case 0: goto cleanup0; \ + case 1: goto cleanup1; \ + case 2: goto cleanup2; \ + default: TCL_UNREACHABLE(); \ + } \ + } while (0) + #define NEXT_INST_V(pcAdjustment, nCleanup, resultHandling) \ CHECK_STACK(); \ do { \ @@ -244,25 +271,23 @@ VarHashFindVar( } else { \ goto cleanupV; \ } \ + TCL_UNREACHABLE(); \ } while (0) #ifndef TCL_COMPILE_DEBUG +#ifndef REMOVE_DEPRECATED_OPCODES #define JUMP_PEEPHOLE_F(condition, pcAdjustment, cleanup) \ do { \ pc += (pcAdjustment); \ switch (*pc) { \ case INST_JUMP_FALSE1: \ - NEXT_INST_F(((condition)? 2 : TclGetInt1AtPtr(pc+1)), (cleanup), 0); \ - break; \ + NEXT_INST_F0(((condition)? 2 : TclGetInt1AtPtr(pc + 1)), (cleanup)); \ case INST_JUMP_TRUE1: \ - NEXT_INST_F(((condition)? TclGetInt1AtPtr(pc+1) : 2), (cleanup), 0); \ - break; \ - case INST_JUMP_FALSE4: \ - NEXT_INST_F(((condition)? 5 : TclGetInt4AtPtr(pc+1)), (cleanup), 0); \ - break; \ - case INST_JUMP_TRUE4: \ - NEXT_INST_F(((condition)? TclGetInt4AtPtr(pc+1) : 5), (cleanup), 0); \ - break; \ + NEXT_INST_F0(((condition)? TclGetInt1AtPtr(pc + 1) : 2), (cleanup)); \ + case INST_JUMP_FALSE: \ + NEXT_INST_F0(((condition)? 5 : TclGetInt4AtPtr(pc + 1)), (cleanup)); \ + case INST_JUMP_TRUE: \ + NEXT_INST_F0(((condition)? TclGetInt4AtPtr(pc + 1) : 5), (cleanup)); \ default: \ if ((condition) < 0) { \ TclNewIntObj(objResultPtr, -1); \ @@ -270,25 +295,21 @@ VarHashFindVar( objResultPtr = TCONST((condition) > 0); \ } \ NEXT_INST_F(0, (cleanup), 1); \ - break; \ } \ + TCL_UNREACHABLE(); \ } while (0) #define JUMP_PEEPHOLE_V(condition, pcAdjustment, cleanup) \ do { \ pc += (pcAdjustment); \ switch (*pc) { \ case INST_JUMP_FALSE1: \ - NEXT_INST_V(((condition)? 2 : TclGetInt1AtPtr(pc+1)), (cleanup), 0); \ - break; \ + NEXT_INST_V(((condition)? 2 : TclGetInt1AtPtr(pc + 1)), (cleanup), 0); \ case INST_JUMP_TRUE1: \ - NEXT_INST_V(((condition)? TclGetInt1AtPtr(pc+1) : 2), (cleanup), 0); \ - break; \ - case INST_JUMP_FALSE4: \ - NEXT_INST_V(((condition)? 5 : TclGetInt4AtPtr(pc+1)), (cleanup), 0); \ - break; \ - case INST_JUMP_TRUE4: \ - NEXT_INST_V(((condition)? TclGetInt4AtPtr(pc+1) : 5), (cleanup), 0); \ - break; \ + NEXT_INST_V(((condition)? TclGetInt1AtPtr(pc + 1) : 2), (cleanup), 0); \ + case INST_JUMP_FALSE: \ + NEXT_INST_V(((condition)? 5 : TclGetInt4AtPtr(pc + 1)), (cleanup), 0); \ + case INST_JUMP_TRUE: \ + NEXT_INST_V(((condition)? TclGetInt4AtPtr(pc + 1) : 5), (cleanup), 0); \ default: \ if ((condition) < 0) { \ TclNewIntObj(objResultPtr, -1); \ @@ -296,10 +317,48 @@ VarHashFindVar( objResultPtr = TCONST((condition) > 0); \ } \ NEXT_INST_V(0, (cleanup), 1); \ - break; \ } \ + TCL_UNREACHABLE(); \ } while (0) -#else /* TCL_COMPILE_DEBUG */ +#else // REMOVE_DEPRECATED_OPCODES +#define JUMP_PEEPHOLE_F(condition, pcAdjustment, cleanup) \ + do { \ + pc += (pcAdjustment); \ + switch (*pc) { \ + case INST_JUMP_FALSE: \ + NEXT_INST_F0(((condition)? 5 : TclGetInt4AtPtr(pc + 1)), (cleanup)); \ + case INST_JUMP_TRUE: \ + NEXT_INST_F0(((condition)? TclGetInt4AtPtr(pc + 1) : 5), (cleanup)); \ + default: \ + if ((condition) < 0) { \ + TclNewIntObj(objResultPtr, -1); \ + } else { \ + objResultPtr = TCONST((condition) > 0); \ + } \ + NEXT_INST_F(0, (cleanup), 1); \ + } \ + TCL_UNREACHABLE(); \ + } while (0) +#define JUMP_PEEPHOLE_V(condition, pcAdjustment, cleanup) \ + do { \ + pc += (pcAdjustment); \ + switch (*pc) { \ + case INST_JUMP_FALSE: \ + NEXT_INST_V(((condition)? 5 : TclGetInt4AtPtr(pc + 1)), (cleanup), 0); \ + case INST_JUMP_TRUE: \ + NEXT_INST_V(((condition)? TclGetInt4AtPtr(pc + 1) : 5), (cleanup), 0); \ + default: \ + if ((condition) < 0) { \ + TclNewIntObj(objResultPtr, -1); \ + } else { \ + objResultPtr = TCONST((condition) > 0); \ + } \ + NEXT_INST_V(0, (cleanup), 1); \ + } \ + TCL_UNREACHABLE(); \ + } while (0) +#endif // REMOVE_DEPRECATED_OPCODES +#else // TCL_COMPILE_DEBUG #define JUMP_PEEPHOLE_F(condition, pcAdjustment, cleanup) \ do{ \ if ((condition) < 0) { \ @@ -308,6 +367,7 @@ VarHashFindVar( objResultPtr = TCONST((condition) > 0); \ } \ NEXT_INST_F((pcAdjustment), (cleanup), 1); \ + TCL_UNREACHABLE(); \ } while (0) #define JUMP_PEEPHOLE_V(condition, pcAdjustment, cleanup) \ do{ \ @@ -317,8 +377,9 @@ VarHashFindVar( objResultPtr = TCONST((condition) > 0); \ } \ NEXT_INST_V((pcAdjustment), (cleanup), 1); \ + TCL_UNREACHABLE(); \ } while (0) -#endif +#endif // TCL_COMPILE_DEBUG /* * Macros used to cache often-referenced Tcl evaluation stack information @@ -364,6 +425,11 @@ VarHashFindVar( #define STACK_BASE(esPtr) ((esPtr)->stackWords - 1) +#define PC_REL ((Tcl_Size)(pc - codePtr->codeStart)) + +#define SIZEd TCL_SIZE_MODIFIER "d" +#define SIZEu TCL_Z_MODIFIER "u" + /* * Macros used to trace instruction execution. The macros TRACE, * TRACE_WITH_OBJ, and O2S are only used inside TclNRExecuteByteCode. O2S is @@ -373,27 +439,27 @@ VarHashFindVar( #ifdef TCL_COMPILE_DEBUG # define TRACE(a) \ while (traceInstructions) { \ - fprintf(stdout, "%2" TCL_SIZE_MODIFIER "d: %2" TCL_SIZE_MODIFIER \ - "d (%" TCL_SIZE_MODIFIER "d) %s ", iPtr->numLevels, \ + fprintf(stdout, "%2" SIZEd ": %2" SIZEd " (%" SIZEd ") %s ", \ + iPtr->numLevels, \ CURR_DEPTH, \ - (pc - codePtr->codeStart), \ + PC_REL, \ GetOpcodeName(pc)); \ printf a; \ break; \ } # define TRACE_APPEND(a) \ - while (traceInstructions) { \ - printf a; \ - break; \ + while (traceInstructions) { \ + printf a; \ + break; \ } # define TRACE_ERROR(interp) \ - TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))) # define TRACE_WITH_OBJ(a, objPtr) \ while (traceInstructions) { \ - fprintf(stdout, "%2" TCL_SIZE_MODIFIER "d: %2" TCL_SIZE_MODIFIER \ - "d (%" TCL_SIZE_MODIFIER "d) %s ", iPtr->numLevels, \ + fprintf(stdout, "%2" SIZEd ": %2" SIZEd " (%" SIZEd ") %s ", \ + iPtr->numLevels, \ CURR_DEPTH, \ - (pc - codePtr->codeStart), \ + PC_REL, \ GetOpcodeName(pc)); \ printf a; \ TclPrintObject(stdout, objPtr, 30); \ @@ -402,13 +468,28 @@ VarHashFindVar( } # define O2S(objPtr) \ (objPtr ? TclGetString(objPtr) : "") -#else /* !TCL_COMPILE_DEBUG */ +# define TRACE_APPEND_OBJ(objPtr) \ + TRACE_APPEND(("\"%.30s\"\n", O2S(objPtr))) +# define TRACE_APPEND_NUM_OBJ(objPtr) \ + TRACE_APPEND(("%.30s\n", O2S(objPtr))) +#else // !TCL_COMPILE_DEBUG # define TRACE(a) # define TRACE_APPEND(a) # define TRACE_ERROR(interp) # define TRACE_WITH_OBJ(a, objPtr) # define O2S(objPtr) -#endif /* TCL_COMPILE_DEBUG */ +# define TRACE_APPEND_OBJ(objPtr) +# define TRACE_APPEND_NUM_OBJ(objPtr) +#endif // TCL_COMPILE_DEBUG + +#ifndef REMOVE_DEPRECATED_OPCODES +#ifdef PANIC_ON_DEPRECATED_OPCODES +#define DEPRECATED_OPCODE_MARK(opcode) \ + Tcl_Panic("%s deprecated for removal", #name) +#else +#define DEPRECATED_OPCODE_MARK(opcode) /* Do nothing. */ +#endif +#endif // REMOVE_DEPRECATED_OPCODES /* * DTrace instruction probe macros. @@ -418,23 +499,23 @@ VarHashFindVar( do { \ if (TCL_DTRACE_INST_DONE_ENABLED()) { \ if (curInstName) { \ - TCL_DTRACE_INST_DONE(curInstName, CURR_DEPTH, \ + TCL_DTRACE_INST_DONE(curInstName, CURR_DEPTH, \ tosPtr); \ } \ curInstName = tclInstructionTable[*pc].name; \ if (TCL_DTRACE_INST_START_ENABLED()) { \ - TCL_DTRACE_INST_START(curInstName, CURR_DEPTH, \ + TCL_DTRACE_INST_START(curInstName, CURR_DEPTH, \ tosPtr); \ } \ } else if (TCL_DTRACE_INST_START_ENABLED()) { \ TCL_DTRACE_INST_START(tclInstructionTable[*pc].name, \ - CURR_DEPTH, tosPtr); \ + CURR_DEPTH, tosPtr); \ } \ } while (0) #define TCL_DTRACE_INST_LAST() \ do { \ if (TCL_DTRACE_INST_DONE_ENABLED() && curInstName) { \ - TCL_DTRACE_INST_DONE(curInstName, CURR_DEPTH, tosPtr);\ + TCL_DTRACE_INST_DONE(curInstName, CURR_DEPTH, tosPtr); \ } \ } while (0) @@ -458,7 +539,7 @@ VarHashFindVar( *(ptrPtr) = (void *) \ (&((objPtr)->internalRep.doubleValue)), TCL_OK) : \ (((objPtr)->bytes != NULL) && ((objPtr)->length == 0)) \ - ? TCL_ERROR : \ + ? TCL_ERROR : \ Tcl_GetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr))) /* @@ -484,7 +565,7 @@ VarHashFindVar( #define IsErroringNaNType(type) ((type) == TCL_NUMBER_NAN) #else #define IsErroringNaNType(type) 0 -#endif +#endif // ACCEPT_NAN /* * Auxiliary tables used to compute powers of small integers. @@ -628,6 +709,8 @@ static Tcl_Obj * ExecuteExtendedBinaryMathOp(Tcl_Interp *interp, static Tcl_Obj * ExecuteExtendedUnaryMathOp(int opcode, Tcl_Obj *valuePtr); static void FreeExprCodeInternalRep(Tcl_Obj *objPtr); +static Tcl_Obj * GenerateArithSeries(Tcl_Interp *interp, Tcl_Obj *from, + Tcl_Obj *to, Tcl_Obj *step, Tcl_Obj *count); static ExceptionRange * GetExceptRangeForPc(const unsigned char *pc, int searchMode, ByteCode *codePtr); static const char * GetSrcInfoForPc(const unsigned char *pc, @@ -638,7 +721,7 @@ static Tcl_Obj ** GrowEvaluationStack(ExecEnv *eePtr, size_t growth, static void IllegalExprOperandType(Tcl_Interp *interp, const char *ord, const unsigned char *pc, Tcl_Obj *opndPtr); static void InitByteCodeExecution(Tcl_Interp *interp); -static inline int wordSkip(void *ptr); +static inline int WordSkip(void *ptr); static void ReleaseDictIterator(Tcl_Obj *objPtr); /* Useful elsewhere, make available in tclInt.h or stubs? */ static Tcl_Obj ** StackAllocWords(Tcl_Interp *interp, size_t numWords); @@ -696,11 +779,7 @@ static void ReleaseDictIterator( Tcl_Obj *objPtr) { - Tcl_DictSearch *searchPtr; - Tcl_Obj *dictPtr; - const Tcl_ObjInternalRep *irPtr; - - irPtr = TclFetchInternalRep(objPtr, &dictIteratorType); + const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objPtr, &dictIteratorType); assert(irPtr != NULL); /* @@ -708,11 +787,11 @@ ReleaseDictIterator( * that we were holding. */ - searchPtr = (Tcl_DictSearch *)irPtr->twoPtrValue.ptr1; + Tcl_DictSearch *searchPtr = (Tcl_DictSearch *)irPtr->twoPtrValue.ptr1; Tcl_DictObjDone(searchPtr); Tcl_Free(searchPtr); - dictPtr = (Tcl_Obj *)irPtr->twoPtrValue.ptr2; + Tcl_Obj *dictPtr = (Tcl_Obj *)irPtr->twoPtrValue.ptr2; TclDecrRefCount(dictPtr); } @@ -810,7 +889,7 @@ TclCreateExecEnv( esPtr->prevPtr = NULL; esPtr->nextPtr = NULL; esPtr->markerPtr = NULL; - esPtr->endPtr = &esPtr->stackWords[size-1]; + esPtr->endPtr = &esPtr->stackWords[size - 1]; esPtr->tosPtr = STACK_BASE(esPtr); Tcl_MutexLock(&execMutex); @@ -863,7 +942,7 @@ TclDeleteExecEnv( { ExecStack *esPtr = eePtr->execStackPtr, *tmpPtr; - cachedInExit = TclInExit(); + cachedInExit = TclInExit(); /* * Delete all stacks in this exec env. @@ -928,18 +1007,17 @@ TclFinalizeExecution(void) (TCL_ALLOCALIGN/sizeof(Tcl_Obj *)) /* - * wordSkip computes how many words have to be skipped until the next aligned + * WordSkip computes how many words have to be skipped until the next aligned * word. Note that we are only interested in the low order bits of ptr, so * that any possible information loss in PTR2INT is of no consequence. */ - static inline int -wordSkip( +WordSkip( void *ptr) { - size_t mask = TCL_ALLOCALIGN-1; - size_t base = PTR2UINT(ptr) & mask; - return (TCL_ALLOCALIGN - base)/sizeof(Tcl_Obj *); + int mask = TCL_ALLOCALIGN - 1; + int base = (int)PTR2INT(ptr) & mask; + return (TCL_ALLOCALIGN - base) / (int)sizeof(Tcl_Obj *); } /* @@ -947,7 +1025,7 @@ wordSkip( */ #define MEMSTART(markerPtr) \ - ((markerPtr) + wordSkip(markerPtr)) + ((markerPtr) + WordSkip(markerPtr)) /* *---------------------------------------------------------------------- @@ -990,10 +1068,10 @@ GrowEvaluationStack( if (needed <= 0) { return MEMSTART(markerPtr); } - } else { #ifndef PURIFY + } else { Tcl_Obj **tmpMarkerPtr = esPtr->tosPtr + 1; - int offset = wordSkip(tmpMarkerPtr); + int offset = WordSkip(tmpMarkerPtr); if (needed + offset < 0) { /* @@ -1008,13 +1086,13 @@ GrowEvaluationStack( *esPtr->markerPtr = (Tcl_Obj *) markerPtr; return memStart; } -#endif +#endif // !PURIFY } /* * Reset move to hold the number of words to be moved to new stack (if * any) and growth to hold the complete stack requirements: add one for - * the marker, (WALLOCALIGN-1) for the maximal possible offset. + * the marker, (WALLOCALIGN - 1) for the maximal possible offset. */ if (move) { @@ -1068,7 +1146,7 @@ GrowEvaluationStack( oldPtr->nextPtr = esPtr; esPtr->prevPtr = oldPtr; esPtr->nextPtr = NULL; - esPtr->endPtr = &esPtr->stackWords[newElems-1]; + esPtr->endPtr = &esPtr->stackWords[newElems - 1]; newStackReady: eePtr->execStackPtr = esPtr; @@ -1088,7 +1166,7 @@ GrowEvaluationStack( memcpy(memStart, MEMSTART(markerPtr), moveWords*sizeof(Tcl_Obj *)); esPtr->tosPtr += moveWords; oldPtr->markerPtr = (Tcl_Obj **) *markerPtr; - oldPtr->tosPtr = markerPtr-1; + oldPtr->tosPtr = markerPtr - 1; } /* @@ -1157,10 +1235,6 @@ TclStackFree( void *freePtr) { Interp *iPtr = (Interp *) interp; - ExecEnv *eePtr; - ExecStack *esPtr; - Tcl_Obj **markerPtr, *marker; - if (iPtr == NULL || iPtr->execEnvPtr == NULL) { Tcl_Free(freePtr); return; @@ -1172,10 +1246,10 @@ TclStackFree( * the previous marker. */ - eePtr = iPtr->execEnvPtr; - esPtr = eePtr->execStackPtr; - markerPtr = esPtr->markerPtr; - marker = *markerPtr; + ExecEnv *eePtr = iPtr->execEnvPtr; + ExecStack *esPtr = eePtr->execStackPtr; + Tcl_Obj **markerPtr = esPtr->markerPtr; + Tcl_Obj *marker = *markerPtr; if ((freePtr != NULL) && (MEMSTART(markerPtr) != (Tcl_Obj **)freePtr)) { Tcl_Panic("TclStackFree: incorrect freePtr (%p != %p). Call out of sequence?", @@ -1211,7 +1285,7 @@ TclStackFree( #ifdef PURIFY eePtr->execStackPtr->nextPtr = NULL; DeleteExecStack(esPtr); -#endif +#endif // PURIFY } else { eePtr->execStackPtr = esPtr; } @@ -1223,12 +1297,11 @@ TclStackAlloc( size_t numBytes) { Interp *iPtr = (Interp *) interp; - size_t numWords; if (iPtr == NULL || iPtr->execEnvPtr == NULL) { return Tcl_Alloc(numBytes); } - numWords = (numBytes + (sizeof(Tcl_Obj *) - 1))/sizeof(Tcl_Obj *); + size_t numWords = (numBytes + (sizeof(Tcl_Obj *) - 1))/sizeof(Tcl_Obj *); return StackAllocWords(interp, numWords); } @@ -1239,24 +1312,20 @@ TclStackRealloc( size_t numBytes) { Interp *iPtr = (Interp *) interp; - ExecEnv *eePtr; - ExecStack *esPtr; - Tcl_Obj **markerPtr; - size_t numWords; if (iPtr == NULL || iPtr->execEnvPtr == NULL) { return Tcl_Realloc(ptr, numBytes); } - eePtr = iPtr->execEnvPtr; - esPtr = eePtr->execStackPtr; - markerPtr = esPtr->markerPtr; + ExecEnv *eePtr = iPtr->execEnvPtr; + ExecStack *esPtr = eePtr->execStackPtr; + Tcl_Obj **markerPtr = esPtr->markerPtr; if (MEMSTART(markerPtr) != (Tcl_Obj **)ptr) { Tcl_Panic("TclStackRealloc: incorrect ptr. Call out of sequence?"); } - numWords = (numBytes + (sizeof(Tcl_Obj *) - 1))/sizeof(Tcl_Obj *); + size_t numWords = (numBytes + (sizeof(Tcl_Obj *) - 1))/sizeof(Tcl_Obj *); return (void *) StackReallocWords(interp, numWords); } @@ -1349,12 +1418,10 @@ Tcl_NRExprObj( Tcl_Obj *objPtr, Tcl_Obj *resultPtr) { - ByteCode *codePtr; Tcl_InterpState state = Tcl_SaveInterpState(interp, TCL_OK); Tcl_ResetResult(interp); - codePtr = CompileExprObj(interp, objPtr); - + ByteCode *codePtr = CompileExprObj(interp, objPtr); Tcl_NRAddCallback(interp, ExprObjCallback, state, resultPtr, NULL, NULL); return TclNRExecuteByteCode(interp, codePtr); @@ -1444,8 +1511,7 @@ CompileExprObj( */ if (compEnv.codeNext == compEnv.codeStart) { - TclEmitPush(TclRegisterLiteral(&compEnv, "0", 1, 0), - &compEnv); + PushLiteral(&compEnv, "0", 1); } /* @@ -1551,7 +1617,7 @@ TclCompileObj( Tcl_Interp *interp, Tcl_Obj *objPtr, const CmdFrame *invoker, - int word) + Tcl_Size word) { Interp *iPtr = (Interp *) interp; ByteCode *codePtr; /* Tcl Internal type of bytecode. */ @@ -1602,7 +1668,7 @@ TclCompileObj( if (!(codePtr->flags & TCL_BYTECODE_PRECOMPILED) && (codePtr->procPtr == NULL) && - (codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr)){ + (codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr)) { goto recompileObj; } @@ -1638,19 +1704,14 @@ TclCompileObj( if (invoker == NULL) { return codePtr; } else { - Tcl_HashEntry *hePtr = - Tcl_FindHashEntry(iPtr->lineBCPtr, codePtr); - ExtCmdLoc *eclPtr; - CmdFrame *ctxCopyPtr; - int redo; - + Tcl_HashEntry *hePtr = Tcl_FindHashEntry(iPtr->lineBCPtr, codePtr); if (!hePtr) { return codePtr; } - - eclPtr = (ExtCmdLoc *)Tcl_GetHashValue(hePtr); - redo = 0; - ctxCopyPtr = (CmdFrame *)TclStackAlloc(interp, sizeof(CmdFrame)); + ExtCmdLoc *eclPtr = (ExtCmdLoc *)Tcl_GetHashValue(hePtr); + int redo = 0; + CmdFrame *ctxCopyPtr = (CmdFrame *) + TclStackAlloc(interp, sizeof(CmdFrame)); *ctxCopyPtr = *invoker; if (invoker->type == TCL_LOCATION_BC) { @@ -1746,7 +1807,6 @@ TclIncrObj( void *ptr1, *ptr2; int type1, type2; mp_int value, incr; - mp_err err; if (Tcl_IsShared(valuePtr)) { Tcl_Panic("%s called with shared object", "TclIncrObj"); @@ -1787,11 +1847,9 @@ TclIncrObj( } if ((type1 == TCL_NUMBER_INT) && (type2 == TCL_NUMBER_INT)) { - Tcl_WideInt w1, w2, sum; - - w1 = *((const Tcl_WideInt *)ptr1); - w2 = *((const Tcl_WideInt *)ptr2); - sum = (Tcl_WideInt)((Tcl_WideUInt)w1 + (Tcl_WideUInt)w2); + Tcl_WideInt w1 = *((const Tcl_WideInt *)ptr1); + Tcl_WideInt w2 = *((const Tcl_WideInt *)ptr2); + Tcl_WideInt sum = (Tcl_WideInt)((Tcl_WideUInt)w1 + (Tcl_WideUInt)w2); /* * Check for overflow. @@ -1805,7 +1863,7 @@ TclIncrObj( Tcl_TakeBignumFromObj(interp, valuePtr, &value); Tcl_GetBignumFromObj(interp, incrPtr, &incr); - err = mp_add(&value, &incr, &value); + mp_err err = mp_add(&value, &incr, &value); mp_clear(&incr); if (err != MP_OKAY) { return TCL_ERROR; @@ -1845,13 +1903,104 @@ ArgumentBCEnter( if (GetSrcInfoForPc(pc, codePtr, NULL, NULL, &cmd)) { TclArgumentBCEnter(interp, objv, objc, codePtr, &tdPtr->cmdFrame, cmd, - pc - codePtr->codeStart); + PC_REL); } } /* *---------------------------------------------------------------------- * + * PrintArgumentWords -- + * + * A helper for TEBC. Prints a sequence of words. + * + * Results: + * None + * + * Side effects: + * May register information about the bytecode in the command frame. + * + *---------------------------------------------------------------------- + */ + +#ifdef TCL_COMPILE_DEBUG +static inline void +PrintArgumentWords( + Tcl_Size objc, + Tcl_Obj *const *objv) +{ + Tcl_Size i; + for (i = 0; i < objc; i++) { + TclPrintObject(stdout, objv[i], 15); + if (i < objc - 1) { + fprintf(stdout, " "); + } + } +} +#endif // TCL_COMPILE_DEBUG + +/* + *---------------------------------------------------------------------- + * + * FindTclOOMethodIndex -- + * + * A helper for INST_TCLOO_NEXT_CLASS in TEBC. Returns the index of a + * class (following the current method) in a call chain. Does not find + * filters (per definition of [nextto]). + * + * Results: + * An index, or TCL_INDEX_NONE if not found. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ +static inline Tcl_Size +FindTclOOMethodIndex( + CallContext *contextPtr, + Class *clsPtr) +{ + Tcl_Size i; + for (i=contextPtr->index+1 ; i<contextPtr->callPtr->numChain ; i++) { + MInvoke *miPtr = contextPtr->callPtr->chain + i; + if (!miPtr->isFilter && miPtr->mPtr->declaringClassPtr == clsPtr) { + return i; + } + } + return TCL_INDEX_NONE; +} + +/* + *---------------------------------------------------------------------- + * + * GetTclOOCallContext -- + * + * A helper for INST_TCLOO_NEXT in TEBC. Returns the call context if one + * exists. + * + * Results: + * The call context, or NULL if not found. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ +static inline CallContext * +GetTclOOCallContext( + Interp *iPtr) +{ + CallFrame *framePtr = iPtr->varFramePtr; + if (!framePtr || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { + return NULL; + } + return (CallContext *) framePtr->clientData; +} + +/* + *---------------------------------------------------------------------- + * * TclNRExecuteByteCode -- * * This procedure executes the instructions of a ByteCode structure. It @@ -1868,7 +2017,7 @@ ArgumentBCEnter( *---------------------------------------------------------------------- */ #define bcFramePtr (&TD->cmdFrame) -#define initCatchTop (TD->stack-1) +#define initCatchTop (TD->stack - 1) #define initTosPtr (initCatchTop+codePtr->maxExceptDepth) #define esPtr (iPtr->execEnvPtr->execStackPtr) @@ -1878,7 +2027,6 @@ TclNRExecuteByteCode( ByteCode *codePtr) /* The bytecode sequence to interpret. */ { Interp *iPtr = (Interp *) interp; - TEBCdata *TD; size_t size = sizeof(TEBCdata) - 1 + (codePtr->maxStackDepth + codePtr->maxExceptDepth) * sizeof(void *); @@ -1898,12 +2046,15 @@ TclNRExecuteByteCode( * execution stack is large enough to execute this ByteCode. */ - TD = (TEBCdata *) GrowEvaluationStack(iPtr->execEnvPtr, numWords, 0); + TEBCdata *TD = (TEBCdata *) GrowEvaluationStack(iPtr->execEnvPtr, numWords, 0); esPtr->tosPtr = initTosPtr; TD->codePtr = codePtr; TD->catchTop = initCatchTop; TD->auxObjList = NULL; +#ifdef TCL_COMPILE_DEBUG + TD->cmdNameBuf[0] = 0; +#endif /* * TIP #280: Initialize the frame. Do not push it yet: it will be pushed @@ -1912,7 +2063,7 @@ TclNRExecuteByteCode( bcFramePtr->type = ((codePtr->flags & TCL_BYTECODE_PRECOMPILED) ? TCL_LOCATION_PREBC : TCL_LOCATION_BC); - bcFramePtr->level = (iPtr->cmdFramePtr ? iPtr->cmdFramePtr->level+1 : 1); + bcFramePtr->level = (iPtr->cmdFramePtr ? iPtr->cmdFramePtr->level + 1 : 1); bcFramePtr->framePtr = iPtr->framePtr; bcFramePtr->nextPtr = iPtr->cmdFramePtr; bcFramePtr->nline = 0; @@ -1967,9 +2118,9 @@ TEBCresume( * Check just the read-traced/write-traced bit of a variable. */ -#define ReadTraced(varPtr) ((varPtr)->flags & VAR_TRACED_READ) -#define WriteTraced(varPtr) ((varPtr)->flags & VAR_TRACED_WRITE) -#define UnsetTraced(varPtr) ((varPtr)->flags & VAR_TRACED_UNSET) +#define ReadTraced(varPtr) ((varPtr)->flags & VAR_TRACED_READ) +#define WriteTraced(varPtr) ((varPtr)->flags & VAR_TRACED_WRITE) +#define UnsetTraced(varPtr) ((varPtr)->flags & VAR_TRACED_UNSET) /* * Bottom of allocated stack holds the NR data @@ -2010,6 +2161,7 @@ TEBCresume( #define catchTop (TD->catchTop) #define codePtr (TD->codePtr) #define curEvalFlags PTR2INT(data[3]) /* calling iPtr->evalFlags */ +#define cmdNameBuf (TD->cmdNameBuf) /* * Globals: variables that store state, must remain valid at all times. @@ -2026,7 +2178,7 @@ TEBCresume( * executing an instruction. */ - int cleanup = PTR2INT(data[2]); + Tcl_Size cleanup = PTR2INT(data[2]); Tcl_Obj *objResultPtr; int checkInterp = 0; /* Indicates when a check of interp readyness * is necessary. Set by CACHE_STACK_INFO() */ @@ -2039,24 +2191,22 @@ TEBCresume( Tcl_Obj *objPtr, *valuePtr, *value2Ptr, *part1Ptr, *part2Ptr, *tmpPtr; Tcl_Obj **objv = NULL; - Tcl_Size length, objc = 0; - int opnd, pcAdjustment; + Tcl_Size length, objc = 0, varIdx, numArgs; + unsigned tblIdx; + int pcAdjustment; Var *varPtr, *arrayPtr; -#ifdef TCL_COMPILE_DEBUG - char cmdNameBuf[21]; -#endif #ifdef TCL_COMPILE_DEBUG int starting = 1; - traceInstructions = (tclTraceExec == 3); + traceInstructions = (tclTraceExec >= TCL_TRACE_BYTECODE_EXEC_INSTRUCTIONS); #endif TEBC_DATA_DIG(); #ifdef TCL_COMPILE_DEBUG - if (!pc && (tclTraceExec >= 2)) { + if (!pc && (tclTraceExec >= TCL_TRACE_BYTECODE_EXEC_COMMANDS)) { PrintByteCodeInfo(codePtr); - fprintf(stdout, " Starting stack top=%" TCL_SIZE_MODIFIER "d\n", CURR_DEPTH); + fprintf(stdout, " Starting stack top=%" SIZEd "\n", CURR_DEPTH); fflush(stdout); } #endif @@ -2115,7 +2265,7 @@ TEBCresume( * instruction. */ - TRACE_WITH_OBJ(("%" TCL_SIZE_MODIFIER "d => ... after \"%.20s\": TCL_OK, result=", + TRACE_WITH_OBJ(("%" SIZEd " => ... after \"%.20s\": TCL_OK, result=", objc, cmdNameBuf), Tcl_GetObjResult(interp)); /* @@ -2162,12 +2312,12 @@ TEBCresume( objPtr = POP_OBJECT(); TclDecrRefCount(objPtr); } - /* FALLTHRU */ + TCL_FALLTHROUGH(); case 2: cleanup2_pushObjResultPtr: objPtr = POP_OBJECT(); TclDecrRefCount(objPtr); - /* FALLTHRU */ + TCL_FALLTHROUGH(); case 1: cleanup1_pushObjResultPtr: objPtr = OBJ_AT_TOS; @@ -2184,17 +2334,17 @@ TEBCresume( objPtr = POP_OBJECT(); TclDecrRefCount(objPtr); } - /* FALLTHRU */ + TCL_FALLTHROUGH(); case 2: cleanup2: objPtr = POP_OBJECT(); TclDecrRefCount(objPtr); - /* FALLTHRU */ + TCL_FALLTHROUGH(); case 1: cleanup1: objPtr = POP_OBJECT(); TclDecrRefCount(objPtr); - /* FALLTHRU */ + TCL_FALLTHROUGH(); case 0: /* * We really want to do nothing now, but this is needed for some @@ -2260,7 +2410,7 @@ TEBCresume( CHECK_STACK(); if (traceInstructions) { - fprintf(stdout, "%2" TCL_SIZE_MODIFIER "d: %2" TCL_SIZE_MODIFIER "d ", iPtr->numLevels, CURR_DEPTH); + fprintf(stdout, "%2" SIZEd ": %2" SIZEd " ", iPtr->numLevels, CURR_DEPTH); TclPrintInstruction(codePtr, pc); fflush(stdout); } @@ -2268,12 +2418,12 @@ TEBCresume( 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 => ", TclGetUInt1AtPtr(pc + 1)), OBJ_AT_TOS); - inst = *(pc += 2); + if (inst == INST_LOAD_SCALAR) { + goto instLoadScalar; + } else if (inst == INST_PUSH) { + PUSH_OBJECT(codePtr->objArrayPtr[TclGetUInt4AtPtr(pc + 1)]); + TRACE_WITH_OBJ(("%u => ", TclGetUInt4AtPtr(pc + 1)), OBJ_AT_TOS); + inst = *(pc += 5); goto peepholeStart; } else if (inst == INST_START_CMD) { /* @@ -2304,8 +2454,8 @@ TEBCresume( switch (inst) { case INST_SYNTAX: case INST_RETURN_IMM: { - int code = TclGetInt4AtPtr(pc+1); - int level = TclGetUInt4AtPtr(pc+5); + int code = TclGetInt4AtPtr(pc + 1); + int level = TclGetUInt4AtPtr(pc + 5); /* * OBJ_AT_TOS is returnOpts, OBJ_UNDER_TOS is resultObjPtr. @@ -2316,7 +2466,7 @@ TEBCresume( if (result == TCL_OK) { TRACE_APPEND(("continuing to next instruction (result=\"%.30s\")\n", O2S(objResultPtr))); - NEXT_INST_F(9, 1, 0); + NEXT_INST_F0(9, 1); } Tcl_SetObjResult(interp, OBJ_UNDER_TOS); if (*pc == INST_SYNTAX) { @@ -2336,7 +2486,7 @@ TEBCresume( OBJ_AT_TOS = objResultPtr; TRACE_APPEND(("continuing to next instruction (result=\"%.30s\")\n", O2S(objResultPtr))); - NEXT_INST_F(1, 0, 0); + NEXT_INST_F0(1, 0); } else if (result == TCL_ERROR) { /* * BEWARE! Must do this in this order, because an error in the @@ -2376,27 +2526,26 @@ TEBCresume( } #ifdef TCL_COMPILE_DEBUG - if (tclTraceExec >= 2) { + if (tclTraceExec >= TCL_TRACE_BYTECODE_EXEC_COMMANDS) { if (traceInstructions) { TRACE_APPEND(("YIELD...\n")); } else { - fprintf(stdout, "%" TCL_SIZE_MODIFIER "d: (%" TCL_T_MODIFIER "d) yielding value \"%.30s\"\n", - iPtr->numLevels, (pc - codePtr->codeStart), - Tcl_GetString(OBJ_AT_TOS)); + fprintf(stdout, "%" SIZEd ": (%" SIZEd ") yielding value \"%.30s\"\n", + iPtr->numLevels, PC_REL, Tcl_GetString(OBJ_AT_TOS)); } fflush(stdout); } #endif - yieldParameter = NULL; /*==CORO_ACTIVATE_YIELD*/ + yieldParameter = CORO_ACTIVATE_YIELD; Tcl_SetObjResult(interp, OBJ_AT_TOS); goto doYield; case INST_YIELD_TO_INVOKE: corPtr = iPtr->execEnvPtr->corPtr; valuePtr = OBJ_AT_TOS; + TRACE(("[%.30s] => ", O2S(valuePtr))); if (!corPtr) { - TRACE(("[%.30s] => ERROR: yield outside coroutine\n", - O2S(valuePtr))); + TRACE_APPEND(("ERROR: yield outside coroutine\n")); Tcl_SetObjResult(interp, Tcl_NewStringObj( "yieldto can only be called in a coroutine", -1)); DECACHE_STACK_INFO(); @@ -2406,8 +2555,7 @@ TEBCresume( goto gotError; } if (((Namespace *)TclGetCurrentNamespace(interp))->flags & NS_DYING) { - TRACE(("[%.30s] => ERROR: yield in deleted\n", - O2S(valuePtr))); + TRACE_APPEND(("ERROR: yield in deleted\n")); Tcl_SetObjResult(interp, Tcl_NewStringObj( "yieldto called in deleted namespace", -1)); DECACHE_STACK_INFO(); @@ -2416,18 +2564,29 @@ TEBCresume( CACHE_STACK_INFO(); goto gotError; } + Tcl_Size yieldTargetLength; + if (TclListObjLength(NULL, valuePtr, &yieldTargetLength) != TCL_OK + || yieldTargetLength < 2) { + TRACE_APPEND(("ERROR: no valid target list in yieldto")); + // Weird case; pretend it's like no arguments given to scripts + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "wrong # args: should be \"yieldto command ?arg ...?\"")); + DECACHE_STACK_INFO(); + Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", (char *)NULL); + CACHE_STACK_INFO(); + goto gotError; + } #ifdef TCL_COMPILE_DEBUG - if (tclTraceExec >= 2) { + if (tclTraceExec >= TCL_TRACE_BYTECODE_EXEC_COMMANDS) { if (traceInstructions) { - TRACE(("[%.30s] => YIELD...\n", O2S(valuePtr))); + TRACE_APPEND(("YIELD...\n")); } else { /* FIXME: What is the right thing to trace? */ - fprintf(stdout, "%" TCL_SIZE_MODIFIER "d: (%" TCL_T_MODIFIER "d) yielding to [%.30s]\n", - iPtr->numLevels, (pc - codePtr->codeStart), - TclGetString(valuePtr)); + fprintf(stdout, "%" SIZEd ": (%" SIZEd ") yielding to [%.30s]\n", + iPtr->numLevels, PC_REL, TclGetString(valuePtr)); + fflush(stdout); } - fflush(stdout); } #endif @@ -2442,7 +2601,7 @@ TEBCresume( TclSetTailcall(interp, valuePtr); corPtr->yieldPtr = valuePtr; iPtr->execEnvPtr = corPtr->eePtr; - yieldParameter = INT2PTR(1); /*==CORO_ACTIVATE_YIELDM*/ + yieldParameter = CORO_ACTIVATE_YIELDM; doYield: /* TIP #280: Record the last piece of info needed by @@ -2464,13 +2623,26 @@ TEBCresume( return TCL_OK; } - case INST_TAILCALL: { + { Tcl_Obj *listPtr; + Tcl_Size i; + +#ifndef REMOVE_DEPRECATED_OPCODES + case INST_TAILCALL1: + DEPRECATED_OPCODE_MARK(INST_TAILCALL1); + numArgs = TclGetUInt1AtPtr(pc + 1); + goto doTailcall; +#endif // REMOVE_DEPRECATED_OPCODES - opnd = TclGetUInt1AtPtr(pc+1); + case INST_TAILCALL: + numArgs = TclGetUInt4AtPtr(pc + 1); +#ifndef REMOVE_DEPRECATED_OPCODES + doTailcall: +#endif // REMOVE_DEPRECATED_OPCODES + TRACE(("%u ", (unsigned) numArgs)); if (!(iPtr->varFramePtr->isProcCallFrame & 1)) { - TRACE(("%d => ERROR: tailcall in non-proc context\n", opnd)); + TRACE_APPEND(("=> ERROR: tailcall in non-proc context\n")); Tcl_SetObjResult(interp, Tcl_NewStringObj( "tailcall can only be called from a proc or lambda", -1)); DECACHE_STACK_INFO(); @@ -2478,44 +2650,138 @@ TEBCresume( CACHE_STACK_INFO(); goto gotError; } + if (numArgs < 2) { + Tcl_Panic("must be at least one command word argument to INST_TAILCALL"); + } #ifdef TCL_COMPILE_DEBUG - /* FIXME: What is the right thing to trace? */ - { - int i; - - TRACE(("%d [", opnd)); - for (i=opnd-1 ; i>=0 ; i--) { - TRACE_APPEND(("\"%.30s\"", O2S(OBJ_AT_DEPTH(i)))); - if (i > 0) { - TRACE_APPEND((" ")); + if (tclTraceExec >= TCL_TRACE_BYTECODE_EXEC_COMMANDS) { + if (traceInstructions) { + TRACE_APPEND(("[")); + for (i=numArgs-1 ; i>=0 ; i--) { + TRACE_APPEND(("\"%.30s\"", O2S(OBJ_AT_DEPTH(i)))); + if (i > 0) { + TRACE_APPEND((" ")); + } } + TRACE_APPEND(("] => REGISTERED TAILCALL...\n")); + } else { + fprintf(stdout, "%" SIZEd ": (%" SIZEd ") tailcalling [%.30s]\n", + iPtr->numLevels, PC_REL, + TclGetString(OBJ_AT_DEPTH(numArgs - 2))); + fflush(stdout); } - TRACE_APPEND(("] => RETURN...")); } -#endif +#endif // TCL_COMPILE_DEBUG /* * Push the evaluation of the called command into the NR callback * stack. */ - listPtr = Tcl_NewListObj(opnd, &OBJ_AT_DEPTH(opnd-1)); - TclListObjSetElement(NULL, listPtr, 0, TclNewNamespaceObj( - (Tcl_Namespace *) iPtr->varFramePtr->nsPtr)); + listPtr = Tcl_NewListObj(numArgs, &OBJ_AT_DEPTH(numArgs - 1)); +#ifndef REMOVE_DEPRECATED_OPCODES + /* New instruction sequence just gets this right. */ + if (inst == INST_TAILCALL1) { + TclListObjSetElement(NULL, listPtr, 0, TclNewNamespaceObj( + TclGetCurrentNamespace(interp))); + } +#endif // REMOVE_DEPRECATED_OPCODES + goto setTailcall; + + case INST_TAILCALL_LIST: + if (!(iPtr->varFramePtr->isProcCallFrame & 1)) { + TRACE((" => ERROR: tailcall in non-proc context\n")); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "tailcall can only be called from a proc or lambda", -1)); + DECACHE_STACK_INFO(); + Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", (char *)NULL); + CACHE_STACK_INFO(); + goto gotError; + } + + listPtr = OBJ_AT_TOS; + +#ifdef TCL_COMPILE_DEBUG + if (tclTraceExec >= TCL_TRACE_BYTECODE_EXEC_COMMANDS) { + if (traceInstructions) { + TRACE(("[")); + TclPrintObject(stdout, listPtr, 40); + TRACE_APPEND(("] => REGISTERED TAILCALL...\n")); + } else { + Tcl_Obj *cmdNameObj; + Tcl_ListObjIndex(NULL, listPtr, 1, &cmdNameObj); + if (cmdNameObj) { + fprintf(stdout, "%" SIZEd ": (%" SIZEd ") tailcalling [%.30s]\n", + iPtr->numLevels, PC_REL, TclGetString(cmdNameObj)); + } else { + fprintf(stdout, "cancelling tailcall\n"); + } + fflush(stdout); + } + } +#endif // TCL_COMPILE_DEBUG + + /* + * Push the evaluation of the called command into the NR callback + * stack, or cancel it if there's no command words. + */ + + setTailcall: if (iPtr->varFramePtr->tailcallPtr) { Tcl_DecrRefCount(iPtr->varFramePtr->tailcallPtr); } - iPtr->varFramePtr->tailcallPtr = listPtr; + // Always at least one word: the namespace name. + ListObjLength(listPtr, i); + if (i > 1) { + Tcl_IncrRefCount(listPtr); + iPtr->varFramePtr->tailcallPtr = listPtr; + } else { + iPtr->varFramePtr->tailcallPtr = NULL; + } result = TCL_RETURN; - cleanup = opnd; + cleanup = 2; goto processExceptionReturn; } + case INST_UPLEVEL: { + Tcl_Obj *levelObj = OBJ_UNDER_TOS; + Tcl_Obj *scriptObj = OBJ_AT_TOS; + CallFrame *framePtr; + CmdFrame *invoker = NULL; + int word = 0; + + TRACE(("\"%.30s\" \"%.30s\" => ", O2S(levelObj), O2S(scriptObj))); + if (TclObjGetFrame(interp, levelObj, &framePtr) == -1) { + TRACE_ERROR(interp); + goto gotError; + } + bcFramePtr->data.tebc.pc = (char *) pc; + iPtr->cmdFramePtr = bcFramePtr; + TclArgumentGet(interp, scriptObj, &invoker, &word); + DECACHE_STACK_INFO(); + pc++; + cleanup = 2; + TEBC_YIELD(); +#ifdef TCL_COMPILE_DEBUG + TRACE_APPEND(("INVOKING...\n")); + if (tclTraceExec >= TCL_TRACE_BYTECODE_EXEC_COMMANDS && !traceInstructions) { + fprintf(stdout, "%" SIZEd ": (%" SIZEd ") invoking [%.30s] in frame \"%.30s\"\n", + iPtr->numLevels, PC_REL, TclGetString(scriptObj), TclGetString(levelObj)); + fflush(stdout); + } +#endif // TCL_COMPILE_DEBUG + TclNRAddCallback(interp, TclUplevelCallback, iPtr->varFramePtr, + NULL, NULL, NULL); + TclNRAddCallback(interp, TclNRPostInvoke, NULL, NULL, NULL, NULL); + iPtr->varFramePtr = framePtr; + iPtr->numLevels++; + return TclNREvalObjEx(interp, scriptObj, 0, invoker, word); + } + case INST_DONE: if (tosPtr > initTosPtr) { - if ((curEvalFlags & TCL_EVAL_DISCARD_RESULT) && (result == TCL_OK)) { /* simulate pop & fast done (like it does continue in loop) */ TRACE_WITH_OBJ(("=> discarding "), OBJ_AT_TOS); @@ -2543,38 +2809,40 @@ TEBCresume( (void) POP_OBJECT(); goto abnormalReturn; - case INST_PUSH4: - objResultPtr = codePtr->objArrayPtr[TclGetUInt4AtPtr(pc+1)]; - TRACE_WITH_OBJ(("%u => ", TclGetUInt4AtPtr(pc+1)), objResultPtr); +#ifndef REMOVE_DEPRECATED_OPCODES + case INST_PUSH1: + DEPRECATED_OPCODE_MARK(INST_PUSH1); + objResultPtr = codePtr->objArrayPtr[TclGetUInt1AtPtr(pc + 1)]; + TRACE_WITH_OBJ(("%u => ", TclGetUInt1AtPtr(pc + 1)), objResultPtr); + NEXT_INST_F(2, 0, 1); +#endif + + case INST_PUSH: + objResultPtr = codePtr->objArrayPtr[TclGetUInt4AtPtr(pc + 1)]; + TRACE_WITH_OBJ(("%u => ", TclGetUInt4AtPtr(pc + 1)), objResultPtr); NEXT_INST_F(5, 0, 1); - break; case INST_POP: TRACE_WITH_OBJ(("=> discarding "), OBJ_AT_TOS); objPtr = POP_OBJECT(); TclDecrRefCount(objPtr); - NEXT_INST_F(1, 0, 0); - break; + NEXT_INST_F0(1, 0); case INST_DUP: objResultPtr = OBJ_AT_TOS; TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(1, 0, 1); - break; case INST_OVER: - opnd = TclGetUInt4AtPtr(pc+1); - objResultPtr = OBJ_AT_DEPTH(opnd); - TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); + numArgs = TclGetUInt4AtPtr(pc + 1); + objResultPtr = OBJ_AT_DEPTH(numArgs); + TRACE_WITH_OBJ(("%u => ", (unsigned) numArgs), objResultPtr); NEXT_INST_F(5, 0, 1); - break; case INST_REVERSE: { - Tcl_Obj **a, **b; - - opnd = TclGetUInt4AtPtr(pc + 1); - a = tosPtr - (opnd - 1); - b = tosPtr; + numArgs = TclGetUInt4AtPtr(pc + 1); + Tcl_Obj **a = tosPtr - (numArgs - 1); + Tcl_Obj **b = tosPtr; while (a < b) { tmpPtr = *a; *a = *b; @@ -2582,39 +2850,40 @@ TEBCresume( a++; b--; } - TRACE(("%u => OK\n", opnd)); - NEXT_INST_F(5, 0, 0); + TRACE(("%u => OK\n", (unsigned) numArgs)); + NEXT_INST_F0(5, 0); } - break; + case INST_SWAP: + tmpPtr = OBJ_UNDER_TOS; + OBJ_UNDER_TOS = OBJ_AT_TOS; + OBJ_AT_TOS = tmpPtr; + TRACE(("=> OK\n")); + NEXT_INST_F0(1, 0); case INST_STR_CONCAT1: - - opnd = TclGetUInt1AtPtr(pc+1); + numArgs = TclGetUInt1AtPtr(pc + 1); DECACHE_STACK_INFO(); - objResultPtr = TclStringCat(interp, opnd, &OBJ_AT_DEPTH(opnd-1), + objResultPtr = TclStringCat(interp, numArgs, &OBJ_AT_DEPTH(numArgs - 1), TCL_STRING_IN_PLACE); + CACHE_STACK_INFO(); if (objResultPtr == NULL) { - CACHE_STACK_INFO(); TRACE_ERROR(interp); goto gotError; } - CACHE_STACK_INFO(); - TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); - NEXT_INST_V(2, opnd, 1); - break; + TRACE_WITH_OBJ(("%u => ", (unsigned)numArgs), objResultPtr); + NEXT_INST_V(2, numArgs, 1); case INST_CONCAT_STK: /* - * Pop the opnd (objc) top stack elements, run through Tcl_ConcatObj, + * Pop the numArgs (objc) top stack elements, run through Tcl_ConcatObj, * and then decrement their ref counts. */ - opnd = TclGetUInt4AtPtr(pc+1); - objResultPtr = Tcl_ConcatObj(opnd, &OBJ_AT_DEPTH(opnd - 1)); - TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); - NEXT_INST_V(5, opnd, 1); - break; + numArgs = TclGetUInt4AtPtr(pc + 1); + objResultPtr = Tcl_ConcatObj(numArgs, &OBJ_AT_DEPTH(numArgs - 1)); + TRACE_WITH_OBJ(("%u => ", (unsigned) numArgs), objResultPtr); + NEXT_INST_V(5, numArgs, 1); case INST_EXPAND_START: /* @@ -2634,9 +2903,8 @@ TEBCresume( objPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(CURR_DEPTH); objPtr->length = 0; PUSH_TAUX_OBJ(objPtr); - TRACE(("=> mark depth as %" TCL_SIZE_MODIFIER "d\n", CURR_DEPTH)); - NEXT_INST_F(1, 0, 0); - break; + TRACE(("=> mark depth as %" SIZEd "\n", CURR_DEPTH)); + NEXT_INST_F0(1, 0); case INST_EXPAND_DROP: /* @@ -2652,14 +2920,10 @@ TEBCresume( /* Ugly abuse! */ starting = 1; #endif - TRACE(("=> drop %" TCL_SIZE_MODIFIER "d items\n", objc)); + TRACE(("=> drop %" SIZEd " items\n", objc)); NEXT_INST_V(1, objc, 0); - case INST_EXPAND_STKTOP: { - Tcl_Size i; - TEBCdata *newTD; - Tcl_Size oldCatchTopOff, oldTosPtrOff; - + case INST_EXPAND_STKTOP: /* * Make sure that the element at stackTop is a list; if not, just * leave with an error. Note that the element from the expand list @@ -2683,13 +2947,13 @@ TEBCresume( auxObjList->length += objc - 1; if ((objc > 1) && (auxObjList->length > 0)) { - length = auxObjList->length /* Total expansion room we need */ - + codePtr->maxStackDepth /* Beyond the original max */ - - CURR_DEPTH; /* Relative to where we are */ + length = auxObjList->length // Total expansion room we need + + codePtr->maxStackDepth // Beyond the original max + - CURR_DEPTH; // Relative to where we are DECACHE_STACK_INFO(); - oldCatchTopOff = catchTop - initCatchTop; - oldTosPtrOff = tosPtr - initTosPtr; - newTD = (TEBCdata *) + Tcl_Size oldCatchTopOff = catchTop - initCatchTop; + Tcl_Size oldTosPtrOff = tosPtr - initTosPtr; + TEBCdata *newTD = (TEBCdata *) GrowEvaluationStack(iPtr->execEnvPtr, length, 1); if (newTD != TD) { /* @@ -2710,23 +2974,22 @@ TEBCresume( * that it has a freeIntRepProc we use Tcl_DecrRefCount(). */ - for (i = 0; i < objc; i++) { - PUSH_OBJECT(objv[i]); + { + Tcl_Size i; + for (i = 0; i < objc; i++) { + PUSH_OBJECT(objv[i]); + } } TRACE_APPEND(("OK\n")); Tcl_DecrRefCount(objPtr); - NEXT_INST_F(5, 0, 0); - } - break; + NEXT_INST_F0(5, 0); case INST_EXPR_STK: { - ByteCode *newCodePtr; - bcFramePtr->data.tebc.pc = (char *) pc; iPtr->cmdFramePtr = bcFramePtr; DECACHE_STACK_INFO(); - newCodePtr = CompileExprObj(interp, OBJ_AT_TOS); + ByteCode *newCodePtr = CompileExprObj(interp, OBJ_AT_TOS); CACHE_STACK_INFO(); cleanup = 1; pc++; @@ -2749,7 +3012,7 @@ TEBCresume( TEBC_YIELD(); /* add TEBCResume for object at top of stack */ return TclNRExecuteByteCode(interp, - TclCompileObj(interp, OBJ_AT_TOS, NULL, 0)); + TclCompileObj(interp, OBJ_AT_TOS, NULL, 0)); case INST_INVOKE_EXPANDED: CLANG_ASSERT(auxObjList); @@ -2766,36 +3029,34 @@ TEBCresume( TclNewObj(objResultPtr); NEXT_INST_F(1, 0, 1); - break; - case INST_INVOKE_STK4: - objc = TclGetUInt4AtPtr(pc+1); + case INST_INVOKE_STK: + objc = TclGetUInt4AtPtr(pc + 1); pcAdjustment = 5; +#ifndef REMOVE_DEPRECATED_OPCODES goto doInvocation; case INST_INVOKE_STK1: - objc = TclGetUInt1AtPtr(pc+1); + DEPRECATED_OPCODE_MARK(INST_INVOKE_STK1); + objc = TclGetUInt1AtPtr(pc + 1); + pcAdjustment = 2; +#endif doInvocation: - objv = &OBJ_AT_DEPTH(objc-1); + objv = &OBJ_AT_DEPTH(objc - 1); cleanup = objc; #ifdef TCL_COMPILE_DEBUG - if (tclTraceExec >= 2) { - Tcl_Size i; - + if (tclTraceExec >= TCL_TRACE_BYTECODE_EXEC_COMMANDS) { if (traceInstructions) { strncpy(cmdNameBuf, TclGetString(objv[0]), 20); - TRACE(("%" TCL_SIZE_MODIFIER "d => call ", objc)); + TRACE(("%" SIZEd " => call ", objc)); } else { - fprintf(stdout, "%" TCL_SIZE_MODIFIER "d: (%" TCL_T_MODIFIER "d) invoking ", iPtr->numLevels, - (pc - codePtr->codeStart)); - } - for (i = 0; i < objc; i++) { - TclPrintObject(stdout, objv[i], 15); - fprintf(stdout, " "); + fprintf(stdout, "%" SIZEd ": (%" SIZEd ") invoking ", + iPtr->numLevels, PC_REL); } + PrintArgumentWords(objc, objv); fprintf(stdout, "\n"); fflush(stdout); } @@ -2823,30 +3084,28 @@ TEBCresume( return TclCommandWordLimitError(interp, objc); } else { return TclNREvalObjv(interp, objc, objv, - TCL_EVAL_NOERR | TCL_EVAL_SOURCE_IN_FRAME, NULL); + TCL_EVAL_NOERR | TCL_EVAL_SOURCE_IN_FRAME, NULL); } case INST_INVOKE_REPLACE: - objc = TclGetUInt4AtPtr(pc+1); - opnd = TclGetUInt1AtPtr(pc+5); + objc = TclGetUInt4AtPtr(pc + 1); + numArgs = TclGetUInt1AtPtr(pc + 5); objPtr = POP_OBJECT(); - objv = &OBJ_AT_DEPTH(objc-1); + objv = &OBJ_AT_DEPTH(objc - 1); cleanup = objc; #ifdef TCL_COMPILE_DEBUG - if (tclTraceExec >= 2) { - Tcl_Size i; - + if (tclTraceExec >= TCL_TRACE_BYTECODE_EXEC_COMMANDS) { if (traceInstructions) { strncpy(cmdNameBuf, TclGetString(objv[0]), 20); - TRACE(("%" TCL_SIZE_MODIFIER "u => call (implementation %s) ", objc, O2S(objPtr))); + TRACE(("%" SIZEd " => call (implementation %s) ", objc, O2S(objPtr))); } else { fprintf(stdout, - "%" TCL_SIZE_MODIFIER "d: (%" TCL_T_MODIFIER "u) invoking (using implementation %s) ", - iPtr->numLevels, (pc - codePtr->codeStart), - O2S(objPtr)); + "%" SIZEd ": (%" SIZEd ") invoking (using implementation %s) ", + iPtr->numLevels, PC_REL, O2S(objPtr)); } + Tcl_Size i; for (i = 0; i < objc; i++) { - if (i < opnd) { + if (i < numArgs) { fprintf(stdout, "<"); TclPrintObject(stdout, objv[i], 15); fprintf(stdout, ">"); @@ -2866,14 +3125,14 @@ TEBCresume( ArgumentBCEnter(interp, codePtr, TD, pc, objc, objv); } - TclInitRewriteEnsemble(interp, opnd, 1, objv); + TclInitRewriteEnsemble(interp, numArgs, 1, objv); { - Tcl_Obj *copyPtr = Tcl_NewListObj(objc - opnd + 1, NULL); + Tcl_Obj *copyPtr = Tcl_NewListObj(objc - numArgs + 1, NULL); Tcl_ListObjAppendElement(NULL, copyPtr, objPtr); Tcl_ListObjReplace(NULL, copyPtr, LIST_MAX, 0, - objc - opnd, objv + opnd); + objc - numArgs, objv + numArgs); Tcl_DecrRefCount(objPtr); objPtr = copyPtr; } @@ -2897,21 +3156,22 @@ TEBCresume( * common execution code. */ +#ifndef REMOVE_DEPRECATED_OPCODES case INST_LOAD_SCALAR1: - instLoadScalar1: - opnd = TclGetUInt1AtPtr(pc+1); - varPtr = LOCAL(opnd); + DEPRECATED_OPCODE_MARK(INST_LOAD_SCALAR1); + varIdx = TclGetUInt1AtPtr(pc + 1); + varPtr = LOCAL(varIdx); while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } - TRACE(("%u => ", opnd)); + TRACE(("%u => ", (unsigned) varIdx)); if (TclIsVarDirectReadable(varPtr)) { /* * No errors, no traces: just get the value. */ objResultPtr = varPtr->value.objPtr; - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + TRACE_APPEND_OBJ(objResultPtr); NEXT_INST_F(2, 0, 1); } pcAdjustment = 2; @@ -2919,21 +3179,23 @@ TEBCresume( arrayPtr = NULL; part1Ptr = part2Ptr = NULL; goto doCallPtrGetVar; +#endif - case INST_LOAD_SCALAR4: - opnd = TclGetUInt4AtPtr(pc+1); - varPtr = LOCAL(opnd); + case INST_LOAD_SCALAR: + instLoadScalar: + varIdx = TclGetUInt4AtPtr(pc + 1); + varPtr = LOCAL(varIdx); while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } - TRACE(("%u => ", opnd)); + TRACE(("%u => ", (unsigned) varIdx)); if (TclIsVarDirectReadable(varPtr)) { /* * No errors, no traces: just get the value. */ objResultPtr = varPtr->value.objPtr; - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + TRACE_APPEND_OBJ(objResultPtr); NEXT_INST_F(5, 0, 1); } pcAdjustment = 5; @@ -2942,23 +3204,26 @@ TEBCresume( part1Ptr = part2Ptr = NULL; goto doCallPtrGetVar; - case INST_LOAD_ARRAY4: - opnd = TclGetUInt4AtPtr(pc+1); + case INST_LOAD_ARRAY: + varIdx = TclGetUInt4AtPtr(pc + 1); pcAdjustment = 5; +#ifndef REMOVE_DEPRECATED_OPCODES goto doLoadArray; case INST_LOAD_ARRAY1: - opnd = TclGetUInt1AtPtr(pc+1); + DEPRECATED_OPCODE_MARK(INST_LOAD_ARRAY1); + varIdx = TclGetUInt1AtPtr(pc + 1); pcAdjustment = 2; doLoadArray: +#endif part1Ptr = NULL; part2Ptr = OBJ_AT_TOS; - arrayPtr = LOCAL(opnd); + arrayPtr = LOCAL(varIdx); while (TclIsVarLink(arrayPtr)) { arrayPtr = arrayPtr->value.linkPtr; } - TRACE(("%u \"%.30s\" => ", opnd, O2S(part2Ptr))); + TRACE(("%u \"%.30s\" => ", (unsigned) varIdx, O2S(part2Ptr))); if (TclIsVarArray(arrayPtr) && !ReadTraced(arrayPtr)) { varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr); if (varPtr && TclIsVarDirectReadable(varPtr)) { @@ -2967,12 +3232,12 @@ TEBCresume( */ objResultPtr = varPtr->value.objPtr; - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + TRACE_APPEND_OBJ(objResultPtr); NEXT_INST_F(pcAdjustment, 1, 1); } } varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr, - TCL_LEAVE_ERR_MSG, "read", 0, 1, arrayPtr, opnd); + TCL_LEAVE_ERR_MSG, "read", 0, 1, arrayPtr, varIdx); if (varPtr == NULL) { TRACE_ERROR(interp); goto gotError; @@ -2988,7 +3253,10 @@ TEBCresume( goto doLoadStk; case INST_LOAD_STK: +#ifndef REMOVE_DEPRECATED_OPCODES + /* Who uses this opcode nowadays? */ case INST_LOAD_SCALAR_STK: +#endif cleanup = 1; part2Ptr = NULL; objPtr = OBJ_AT_TOS; /* variable name */ @@ -3010,11 +3278,11 @@ TEBCresume( */ objResultPtr = varPtr->value.objPtr; - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + TRACE_APPEND_OBJ(objResultPtr); NEXT_INST_V(1, cleanup, 1); } pcAdjustment = 1; - opnd = -1; + varIdx = -1; doCallPtrGetVar: /* @@ -3024,13 +3292,13 @@ TEBCresume( DECACHE_STACK_INFO(); objResultPtr = TclPtrGetVarIdx(interp, varPtr, arrayPtr, - part1Ptr, part2Ptr, TCL_LEAVE_ERR_MSG, opnd); + part1Ptr, part2Ptr, TCL_LEAVE_ERR_MSG, varIdx); CACHE_STACK_INFO(); if (!objResultPtr) { TRACE_ERROR(interp); goto gotError; } - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + TRACE_APPEND_OBJ(objResultPtr); NEXT_INST_V(pcAdjustment, cleanup, 1); /* @@ -3047,20 +3315,25 @@ TEBCresume( int storeFlags; Tcl_Size len; - case INST_STORE_ARRAY4: - opnd = TclGetUInt4AtPtr(pc+1); - pcAdjustment = 5; - goto doStoreArrayDirect; - +#ifndef REMOVE_DEPRECATED_OPCODES case INST_STORE_ARRAY1: - opnd = TclGetUInt1AtPtr(pc+1); + DEPRECATED_OPCODE_MARK(INST_STORE_ARRAY1); + varIdx = TclGetUInt1AtPtr(pc + 1); pcAdjustment = 2; + goto doStoreArrayDirect; +#endif + case INST_STORE_ARRAY: + varIdx = TclGetUInt4AtPtr(pc + 1); + pcAdjustment = 5; + +#ifndef REMOVE_DEPRECATED_OPCODES doStoreArrayDirect: +#endif valuePtr = OBJ_AT_TOS; part2Ptr = OBJ_UNDER_TOS; - arrayPtr = LOCAL(opnd); - TRACE(("%u \"%.30s\" <- \"%.30s\" => ", opnd, O2S(part2Ptr), + arrayPtr = LOCAL(varIdx); + TRACE(("%u \"%.30s\" <- \"%.30s\" => ", (unsigned) varIdx, O2S(part2Ptr), O2S(valuePtr))); while (TclIsVarLink(arrayPtr)) { arrayPtr = arrayPtr->value.linkPtr; @@ -3079,19 +3352,24 @@ TEBCresume( part1Ptr = NULL; goto doStoreArrayDirectFailed; - case INST_STORE_SCALAR4: - opnd = TclGetUInt4AtPtr(pc+1); - pcAdjustment = 5; - goto doStoreScalarDirect; - +#ifndef REMOVE_DEPRECATED_OPCODES case INST_STORE_SCALAR1: - opnd = TclGetUInt1AtPtr(pc+1); + DEPRECATED_OPCODE_MARK(INST_STORE_SCALAR1); + varIdx = TclGetUInt1AtPtr(pc + 1); pcAdjustment = 2; + goto doStoreScalarDirect; +#endif + case INST_STORE_SCALAR: + varIdx = TclGetUInt4AtPtr(pc + 1); + pcAdjustment = 5; + +#ifndef REMOVE_DEPRECATED_OPCODES doStoreScalarDirect: +#endif valuePtr = OBJ_AT_TOS; - varPtr = LOCAL(opnd); - TRACE(("%u <- \"%.30s\" => ", opnd, O2S(valuePtr))); + varPtr = LOCAL(varIdx); + TRACE(("%u <- \"%.30s\" => ", (unsigned) varIdx, O2S(valuePtr))); while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } @@ -3117,13 +3395,13 @@ TEBCresume( #ifndef TCL_COMPILE_DEBUG if (pc[pcAdjustment] == INST_POP) { tosPtr--; - NEXT_INST_F((pcAdjustment+1), 0, 0); + NEXT_INST_F0(pcAdjustment + 1, 0); } #else - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + TRACE_APPEND_OBJ(objResultPtr); #endif Tcl_IncrRefCount(objResultPtr); - NEXT_INST_F(pcAdjustment, 0, 0); + NEXT_INST_F0(pcAdjustment, 0); case INST_LAPPEND_STK: valuePtr = OBJ_AT_TOS; /* value to append */ @@ -3158,7 +3436,10 @@ TEBCresume( goto doStoreStk; case INST_STORE_STK: +#ifndef REMOVE_DEPRECATED_OPCODES + /* Who uses this opcode nowadays? */ case INST_STORE_SCALAR_STK: +#endif valuePtr = OBJ_AT_TOS; part2Ptr = NULL; storeFlags = TCL_LEAVE_ERR_MSG; @@ -3182,40 +3463,46 @@ TEBCresume( } cleanup = ((part2Ptr == NULL)? 2 : 3); pcAdjustment = 1; - opnd = -1; + varIdx = -1; goto doCallPtrSetVar; - case INST_LAPPEND_ARRAY4: - opnd = TclGetUInt4AtPtr(pc+1); + case INST_LAPPEND_ARRAY: + varIdx = TclGetUInt4AtPtr(pc + 1); pcAdjustment = 5; storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE | TCL_LIST_ELEMENT); goto doStoreArray; +#ifndef REMOVE_DEPRECATED_OPCODES case INST_LAPPEND_ARRAY1: - opnd = TclGetUInt1AtPtr(pc+1); + DEPRECATED_OPCODE_MARK(INST_LAPPEND_ARRAY1); + varIdx = TclGetUInt1AtPtr(pc + 1); pcAdjustment = 2; storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE | TCL_LIST_ELEMENT); goto doStoreArray; +#endif - case INST_APPEND_ARRAY4: - opnd = TclGetUInt4AtPtr(pc+1); + case INST_APPEND_ARRAY: + varIdx = TclGetUInt4AtPtr(pc + 1); pcAdjustment = 5; storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); +#ifndef REMOVE_DEPRECATED_OPCODES goto doStoreArray; case INST_APPEND_ARRAY1: - opnd = TclGetUInt1AtPtr(pc+1); + DEPRECATED_OPCODE_MARK(INST_APPEND_ARRAY1); + varIdx = TclGetUInt1AtPtr(pc + 1); pcAdjustment = 2; storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); goto doStoreArray; +#endif doStoreArray: valuePtr = OBJ_AT_TOS; part2Ptr = OBJ_UNDER_TOS; - arrayPtr = LOCAL(opnd); - TRACE(("%u \"%.30s\" <- \"%.30s\" => ", opnd, O2S(part2Ptr), + arrayPtr = LOCAL(varIdx); + TRACE(("%u \"%.30s\" <- \"%.30s\" => ", (unsigned) varIdx, O2S(part2Ptr), O2S(valuePtr))); while (TclIsVarLink(arrayPtr)) { arrayPtr = arrayPtr->value.linkPtr; @@ -3225,43 +3512,49 @@ TEBCresume( doStoreArrayDirectFailed: varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr, - TCL_LEAVE_ERR_MSG, "set", 1, 1, arrayPtr, opnd); + TCL_LEAVE_ERR_MSG, "set", 1, 1, arrayPtr, varIdx); if (!varPtr) { TRACE_ERROR(interp); goto gotError; } goto doCallPtrSetVar; - case INST_LAPPEND_SCALAR4: - opnd = TclGetUInt4AtPtr(pc+1); + case INST_LAPPEND_SCALAR: + varIdx = TclGetUInt4AtPtr(pc + 1); pcAdjustment = 5; storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE | TCL_LIST_ELEMENT); goto doStoreScalar; +#ifndef REMOVE_DEPRECATED_OPCODES case INST_LAPPEND_SCALAR1: - opnd = TclGetUInt1AtPtr(pc+1); + DEPRECATED_OPCODE_MARK(INST_LAPPEND_SCALAR1); + varIdx = TclGetUInt1AtPtr(pc + 1); pcAdjustment = 2; storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE | TCL_LIST_ELEMENT); goto doStoreScalar; +#endif - case INST_APPEND_SCALAR4: - opnd = TclGetUInt4AtPtr(pc+1); + case INST_APPEND_SCALAR: + varIdx = TclGetUInt4AtPtr(pc + 1); pcAdjustment = 5; storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); goto doStoreScalar; +#ifndef REMOVE_DEPRECATED_OPCODES case INST_APPEND_SCALAR1: - opnd = TclGetUInt1AtPtr(pc+1); + DEPRECATED_OPCODE_MARK(INST_APPEND_ARRAY1); + varIdx = TclGetUInt1AtPtr(pc + 1); pcAdjustment = 2; storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); goto doStoreScalar; +#endif doStoreScalar: valuePtr = OBJ_AT_TOS; - varPtr = LOCAL(opnd); - TRACE(("%u <- \"%.30s\" => ", opnd, O2S(valuePtr))); + varPtr = LOCAL(varIdx); + TRACE(("%u <- \"%.30s\" => ", (unsigned) varIdx, O2S(valuePtr))); while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } @@ -3272,7 +3565,7 @@ TEBCresume( doCallPtrSetVar: DECACHE_STACK_INFO(); objResultPtr = TclPtrSetVarIdx(interp, varPtr, arrayPtr, - part1Ptr, part2Ptr, valuePtr, storeFlags, opnd); + part1Ptr, part2Ptr, valuePtr, storeFlags, varIdx); CACHE_STACK_INFO(); if (!objResultPtr) { TRACE_ERROR(interp); @@ -3280,28 +3573,28 @@ TEBCresume( } #ifndef TCL_COMPILE_DEBUG if (pc[pcAdjustment] == INST_POP) { - NEXT_INST_V((pcAdjustment+1), cleanup, 0); + NEXT_INST_V(pcAdjustment + 1, cleanup, 0); } #endif - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + TRACE_APPEND_OBJ(objResultPtr); NEXT_INST_V(pcAdjustment, cleanup, 1); case INST_LAPPEND_LIST: - opnd = TclGetUInt4AtPtr(pc+1); + varIdx = TclGetUInt4AtPtr(pc + 1); valuePtr = OBJ_AT_TOS; - varPtr = LOCAL(opnd); + varPtr = LOCAL(varIdx); cleanup = 1; pcAdjustment = 5; while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } - TRACE(("%u <- \"%.30s\" => ", opnd, O2S(valuePtr))); + TRACE(("%u <- \"%.30s\" => ", (unsigned) varIdx, O2S(valuePtr))); if (TclListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK) { TRACE_ERROR(interp); goto gotError; } - if (TclIsVarDirectReadable(varPtr) + if (objc && TclIsVarDirectReadable(varPtr) && TclIsVarDirectWritable(varPtr)) { goto lappendListDirect; } @@ -3310,24 +3603,24 @@ TEBCresume( goto lappendListPtr; case INST_LAPPEND_LIST_ARRAY: - opnd = TclGetUInt4AtPtr(pc+1); + varIdx = TclGetUInt4AtPtr(pc + 1); valuePtr = OBJ_AT_TOS; part1Ptr = NULL; part2Ptr = OBJ_UNDER_TOS; - arrayPtr = LOCAL(opnd); + arrayPtr = LOCAL(varIdx); cleanup = 2; pcAdjustment = 5; while (TclIsVarLink(arrayPtr)) { arrayPtr = arrayPtr->value.linkPtr; } TRACE(("%u \"%.30s\" \"%.30s\" => ", - opnd, O2S(part2Ptr), O2S(valuePtr))); + (unsigned) varIdx, O2S(part2Ptr), O2S(valuePtr))); if (TclListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK) { TRACE_ERROR(interp); goto gotError; } - if (TclIsVarArray(arrayPtr) && !ReadTraced(arrayPtr) + if (objc && TclIsVarArray(arrayPtr) && !ReadTraced(arrayPtr) && !WriteTraced(arrayPtr)) { varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr); if (varPtr && TclIsVarDirectReadable(varPtr) @@ -3336,7 +3629,7 @@ TEBCresume( } } varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr, - TCL_LEAVE_ERR_MSG, "set", 1, 1, arrayPtr, opnd); + TCL_LEAVE_ERR_MSG, "set", 1, 1, arrayPtr, varIdx); if (varPtr == NULL) { TRACE_ERROR(interp); goto gotError; @@ -3380,13 +3673,12 @@ TEBCresume( TRACE_ERROR(interp); goto gotError; } - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + TRACE_APPEND_OBJ(objResultPtr); NEXT_INST_V(pcAdjustment, cleanup, 1); lappendList: - opnd = -1; - if (TclListObjGetElements(interp, valuePtr, &objc, &objv) - != TCL_OK) { + varIdx = -1; + if (TclListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK) { TRACE_ERROR(interp); goto gotError; } @@ -3408,7 +3700,7 @@ TEBCresume( } DECACHE_STACK_INFO(); objResultPtr = TclPtrGetVarIdx(interp, varPtr, arrayPtr, - part1Ptr, part2Ptr, TCL_LEAVE_ERR_MSG, opnd); + part1Ptr, part2Ptr, TCL_LEAVE_ERR_MSG, varIdx); CACHE_STACK_INFO(); if (TclIsVarInHash(varPtr)) { VarHashRefCount(varPtr)--; @@ -3418,41 +3710,48 @@ TEBCresume( } { - int createdNewObj = 0; Tcl_Obj *valueToAssign; if (!objResultPtr) { - valueToAssign = valuePtr; + if (objc == 0) { + /* + * The variable doesn't exist yet. Just create it with an + * empty initial value. + */ + TclNewObj(valueToAssign); + } else { + valueToAssign = valuePtr; + } } else if (TclListObjLength(interp, objResultPtr, &len)!=TCL_OK) { - TRACE_ERROR(interp); - goto gotError; + goto errorInLappendListPtr; + } else if (objc == 0) { + goto skipLappendListAssign; } else { if (Tcl_IsShared(objResultPtr)) { valueToAssign = Tcl_DuplicateObj(objResultPtr); - createdNewObj = 1; } else { valueToAssign = objResultPtr; } - if (TclListObjAppendElements(interp, valueToAssign, + if (Tcl_ListObjReplace(interp, valueToAssign, len, 0, objc, objv) != TCL_OK) { - if (createdNewObj) { - TclDecrRefCount(valueToAssign); - } + Tcl_BounceRefCount(valueToAssign); goto errorInLappendListPtr; } } DECACHE_STACK_INFO(); objResultPtr = TclPtrSetVarIdx(interp, varPtr, arrayPtr, part1Ptr, - part2Ptr, valueToAssign, TCL_LEAVE_ERR_MSG, opnd); + part2Ptr, valueToAssign, TCL_LEAVE_ERR_MSG, varIdx); CACHE_STACK_INFO(); - if (!objResultPtr) { - errorInLappendListPtr: - TRACE_ERROR(interp); - goto gotError; - } } - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + skipLappendListAssign: + if (!objResultPtr) { + goto errorInLappendListPtr; + } + TRACE_APPEND_OBJ(objResultPtr); NEXT_INST_V(pcAdjustment, cleanup, 1); + errorInLappendListPtr: + TRACE_ERROR(interp); + goto gotError; } /* @@ -3472,29 +3771,50 @@ TEBCresume( Tcl_WideInt w; long increment; +#ifndef REMOVE_DEPRECATED_OPCODES case INST_INCR_SCALAR1: case INST_INCR_ARRAY1: +#endif case INST_INCR_ARRAY_STK: case INST_INCR_SCALAR_STK: case INST_INCR_STK: - opnd = TclGetUInt1AtPtr(pc+1); + varIdx = TclGetUInt1AtPtr(pc + 1); incrPtr = POP_OBJECT(); switch (*pc) { +#ifndef REMOVE_DEPRECATED_OPCODES case INST_INCR_SCALAR1: + DEPRECATED_OPCODE_MARK(INST_INCR_SCALAR1); pcAdjustment = 2; goto doIncrScalar; case INST_INCR_ARRAY1: + DEPRECATED_OPCODE_MARK(INST_INCR_ARRAY1); pcAdjustment = 2; goto doIncrArray; +#endif default: pcAdjustment = 1; goto doIncrStk; } + case INST_INCR_SCALAR: + case INST_INCR_ARRAY: + varIdx = TclGetUInt4AtPtr(pc + 1); + incrPtr = POP_OBJECT(); + pcAdjustment = 5; + switch (*pc) { + case INST_INCR_SCALAR: + goto doIncrScalar; + case INST_INCR_ARRAY: + goto doIncrArray; + default: + Tcl_Panic("unknown instruction"); + TCL_UNREACHABLE(); + } + case INST_INCR_ARRAY_STK_IMM: case INST_INCR_SCALAR_STK_IMM: case INST_INCR_STK_IMM: - increment = TclGetInt1AtPtr(pc+1); + increment = TclGetInt1AtPtr(pc + 1); TclNewIntObj(incrPtr, increment); Tcl_IncrRefCount(incrPtr); pcAdjustment = 2; @@ -3512,7 +3832,7 @@ TEBCresume( TRACE(("\"%.30s\" (by %ld) => ", O2S(objPtr), increment)); } part1Ptr = objPtr; - opnd = -1; + varIdx = -1; varPtr = TclObjLookupVarEx(interp, objPtr, part2Ptr, TCL_LEAVE_ERR_MSG, "read", 1, 1, &arrayPtr); if (!varPtr) { @@ -3527,24 +3847,36 @@ TEBCresume( cleanup = ((part2Ptr == NULL)? 1 : 2); goto doIncrVar; +#ifndef REMOVE_DEPRECATED_OPCODES case INST_INCR_ARRAY1_IMM: - opnd = TclGetUInt1AtPtr(pc+1); - increment = TclGetInt1AtPtr(pc+2); + DEPRECATED_OPCODE_MARK(INST_INCR_ARRAY1_IMM); + varIdx = TclGetUInt1AtPtr(pc + 1); + increment = TclGetInt1AtPtr(pc + 2); TclNewIntObj(incrPtr, increment); Tcl_IncrRefCount(incrPtr); pcAdjustment = 3; + goto doIncrArray; +#endif + + case INST_INCR_ARRAY_IMM: + varIdx = TclGetUInt4AtPtr(pc + 1); + increment = TclGetInt1AtPtr(pc + 5); + TclNewIntObj(incrPtr, increment); + Tcl_IncrRefCount(incrPtr); + pcAdjustment = 6; doIncrArray: part1Ptr = NULL; part2Ptr = OBJ_AT_TOS; - arrayPtr = LOCAL(opnd); + arrayPtr = LOCAL(varIdx); cleanup = 1; while (TclIsVarLink(arrayPtr)) { arrayPtr = arrayPtr->value.linkPtr; } - TRACE(("%u \"%.30s\" (by %ld) => ", opnd, O2S(part2Ptr), increment)); + TRACE(("%u \"%.30s\" (by %ld) => ", (unsigned) varIdx, O2S(part2Ptr), + increment)); varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr, - TCL_LEAVE_ERR_MSG, "read", 1, 1, arrayPtr, opnd); + TCL_LEAVE_ERR_MSG, "read", 1, 1, arrayPtr, varIdx); if (!varPtr) { TRACE_ERROR(interp); Tcl_DecrRefCount(incrPtr); @@ -3552,12 +3884,23 @@ TEBCresume( } goto doIncrVar; +#ifndef REMOVE_DEPRECATED_OPCODES case INST_INCR_SCALAR1_IMM: - opnd = TclGetUInt1AtPtr(pc+1); - increment = TclGetInt1AtPtr(pc+2); + DEPRECATED_OPCODE_MARK(INST_INCR_SCALAR1_IMM); + varIdx = TclGetUInt1AtPtr(pc + 1); + increment = TclGetInt1AtPtr(pc + 2); pcAdjustment = 3; + goto doIncrScalarImm; +#endif + case INST_INCR_SCALAR_IMM: + varIdx = TclGetUInt4AtPtr(pc + 1); + increment = TclGetInt1AtPtr(pc + 5); + pcAdjustment = 6; +#ifndef REMOVE_DEPRECATED_OPCODES + doIncrScalarImm: +#endif cleanup = 0; - varPtr = LOCAL(opnd); + varPtr = LOCAL(varIdx); while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } @@ -3579,7 +3922,7 @@ TEBCresume( */ if (!Overflowing(augend, increment, sum)) { - TRACE(("%u %ld => ", opnd, increment)); + TRACE(("%u %ld => ", (unsigned)varIdx, increment)); if (Tcl_IsShared(objPtr)) { objPtr->refCount--; /* We know it's shared. */ TclNewIntObj(objResultPtr, sum); @@ -3593,7 +3936,7 @@ TEBCresume( } w = (Tcl_WideInt)augend; - TRACE(("%u %ld => ", opnd, increment)); + TRACE(("%u %ld => ", (unsigned)varIdx, increment)); if (Tcl_IsShared(objPtr)) { objPtr->refCount--; /* We know it's shared. */ TclNewIntObj(objResultPtr, w + increment); @@ -3638,14 +3981,14 @@ TEBCresume( Tcl_IncrRefCount(incrPtr); doIncrScalar: - varPtr = LOCAL(opnd); + varPtr = LOCAL(varIdx); while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } arrayPtr = NULL; part1Ptr = part2Ptr = NULL; cleanup = 0; - TRACE(("%u %s => ", opnd, TclGetString(incrPtr))); + TRACE(("%u %s => ", (unsigned)varIdx, TclGetString(incrPtr))); doIncrVar: if (TclIsVarDirectModifyable2(varPtr, arrayPtr)) { @@ -3667,7 +4010,7 @@ TEBCresume( } else { DECACHE_STACK_INFO(); objResultPtr = TclPtrIncrObjVarIdx(interp, varPtr, arrayPtr, - part1Ptr, part2Ptr, incrPtr, TCL_LEAVE_ERR_MSG, opnd); + part1Ptr, part2Ptr, incrPtr, TCL_LEAVE_ERR_MSG, varIdx); CACHE_STACK_INFO(); Tcl_DecrRefCount(incrPtr); if (objResultPtr == NULL) { @@ -3676,10 +4019,10 @@ TEBCresume( } } doneIncr: - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + TRACE_APPEND_OBJ(objResultPtr); #ifndef TCL_COMPILE_DEBUG if (pc[pcAdjustment] == INST_POP) { - NEXT_INST_V((pcAdjustment+1), cleanup, 0); + NEXT_INST_V(pcAdjustment + 1, cleanup, 0); } #endif NEXT_INST_V(pcAdjustment, cleanup, 1); @@ -3694,16 +4037,16 @@ TEBCresume( case INST_EXIST_SCALAR: cleanup = 0; pcAdjustment = 5; - opnd = TclGetUInt4AtPtr(pc+1); - varPtr = LOCAL(opnd); + varIdx = TclGetUInt4AtPtr(pc + 1); + varPtr = LOCAL(varIdx); while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } - TRACE(("%u => ", opnd)); + TRACE(("%u => ", (unsigned) varIdx)); if (ReadTraced(varPtr)) { DECACHE_STACK_INFO(); TclObjCallVarTraces(iPtr, NULL, varPtr, NULL, NULL, - TCL_TRACE_READS, 0, opnd); + TCL_TRACE_READS, 0, varIdx); CACHE_STACK_INFO(); if (TclIsVarUndefined(varPtr)) { TclCleanupVar(varPtr, NULL); @@ -3715,13 +4058,13 @@ TEBCresume( case INST_EXIST_ARRAY: cleanup = 1; pcAdjustment = 5; - opnd = TclGetUInt4AtPtr(pc+1); + varIdx = TclGetUInt4AtPtr(pc + 1); part2Ptr = OBJ_AT_TOS; - arrayPtr = LOCAL(opnd); + arrayPtr = LOCAL(varIdx); while (TclIsVarLink(arrayPtr)) { arrayPtr = arrayPtr->value.linkPtr; } - TRACE(("%u \"%.30s\" => ", opnd, O2S(part2Ptr))); + TRACE(("%u \"%.30s\" => ", (unsigned)varIdx, O2S(part2Ptr))); if (TclIsVarArray(arrayPtr) && !ReadTraced(arrayPtr)) { varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr); if (!varPtr || !ReadTraced(varPtr)) { @@ -3729,12 +4072,12 @@ TEBCresume( } } varPtr = TclLookupArrayElement(interp, NULL, part2Ptr, 0, "access", - 0, 1, arrayPtr, opnd); + 0, 1, arrayPtr, varIdx); if (varPtr) { if (ReadTraced(varPtr) || (arrayPtr && ReadTraced(arrayPtr))) { DECACHE_STACK_INFO(); TclObjCallVarTraces(iPtr, arrayPtr, varPtr, NULL, part2Ptr, - TCL_TRACE_READS, 0, opnd); + TCL_TRACE_READS, 0, varIdx); CACHE_STACK_INFO(); } if (TclIsVarUndefined(varPtr)) { @@ -3796,13 +4139,13 @@ TEBCresume( int flags; case INST_UNSET_SCALAR: - flags = TclGetUInt1AtPtr(pc+1) ? TCL_LEAVE_ERR_MSG : 0; - opnd = TclGetUInt4AtPtr(pc+2); - varPtr = LOCAL(opnd); + flags = TclGetUInt1AtPtr(pc + 1) ? TCL_LEAVE_ERR_MSG : 0; + varIdx = TclGetUInt4AtPtr(pc + 2); + varPtr = LOCAL(varIdx); while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } - TRACE(("%s %u => ", (flags ? "normal" : "noerr"), opnd)); + TRACE(("%s %u => ", (flags ? "normal" : "noerr"), (unsigned)varIdx)); if (TclIsVarDirectUnsettable(varPtr) && !TclIsVarInHash(varPtr)) { /* * No errors, no traces, no searches: just make the variable cease @@ -3816,28 +4159,28 @@ TEBCresume( } varPtr->value.objPtr = NULL; TRACE_APPEND(("OK\n")); - NEXT_INST_F(6, 0, 0); + NEXT_INST_F0(6, 0); } slowUnsetScalar: DECACHE_STACK_INFO(); if (TclPtrUnsetVarIdx(interp, varPtr, NULL, NULL, NULL, flags, - opnd) != TCL_OK && flags) { + varIdx) != TCL_OK && flags) { goto errorInUnset; } CACHE_STACK_INFO(); - NEXT_INST_F(6, 0, 0); + NEXT_INST_F0(6, 0); case INST_UNSET_ARRAY: - flags = TclGetUInt1AtPtr(pc+1) ? TCL_LEAVE_ERR_MSG : 0; - opnd = TclGetUInt4AtPtr(pc+2); + flags = TclGetUInt1AtPtr(pc + 1) ? TCL_LEAVE_ERR_MSG : 0; + varIdx = TclGetUInt4AtPtr(pc + 2); part2Ptr = OBJ_AT_TOS; - arrayPtr = LOCAL(opnd); + arrayPtr = LOCAL(varIdx); while (TclIsVarLink(arrayPtr)) { arrayPtr = arrayPtr->value.linkPtr; } TRACE(("%s %u \"%.30s\" => ", - (flags ? "normal" : "noerr"), opnd, O2S(part2Ptr))); + (flags ? "normal" : "noerr"), (unsigned)varIdx, O2S(part2Ptr))); if (TclIsVarArray(arrayPtr) && !UnsetTraced(arrayPtr) && !(arrayPtr->flags & VAR_SEARCH_ACTIVE)) { varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr); @@ -3856,33 +4199,33 @@ TEBCresume( goto slowUnsetArray; } TRACE_APPEND(("OK\n")); - NEXT_INST_F(6, 1, 0); + NEXT_INST_F0(6, 1); } else if (!varPtr && !(flags & TCL_LEAVE_ERR_MSG)) { /* * Don't need to do anything here. */ TRACE_APPEND(("OK\n")); - NEXT_INST_F(6, 1, 0); + NEXT_INST_F0(6, 1); } } slowUnsetArray: DECACHE_STACK_INFO(); varPtr = TclLookupArrayElement(interp, NULL, part2Ptr, flags, "unset", - 0, 0, arrayPtr, opnd); + 0, 0, arrayPtr, varIdx); if (!varPtr) { if (flags & TCL_LEAVE_ERR_MSG) { goto errorInUnset; } } else if (TclPtrUnsetVarIdx(interp, varPtr, arrayPtr, NULL, part2Ptr, - flags, opnd) != TCL_OK && (flags & TCL_LEAVE_ERR_MSG)) { + flags, varIdx) != TCL_OK && (flags & TCL_LEAVE_ERR_MSG)) { goto errorInUnset; } CACHE_STACK_INFO(); - NEXT_INST_F(6, 1, 0); + NEXT_INST_F0(6, 1); case INST_UNSET_ARRAY_STK: - flags = TclGetUInt1AtPtr(pc+1) ? TCL_LEAVE_ERR_MSG : 0; + flags = TclGetUInt1AtPtr(pc + 1) ? TCL_LEAVE_ERR_MSG : 0; cleanup = 2; part2Ptr = OBJ_AT_TOS; /* element name */ part1Ptr = OBJ_UNDER_TOS; /* array name */ @@ -3891,7 +4234,7 @@ TEBCresume( goto doUnsetStk; case INST_UNSET_STK: - flags = TclGetUInt1AtPtr(pc+1) ? TCL_LEAVE_ERR_MSG : 0; + flags = TclGetUInt1AtPtr(pc + 1) ? TCL_LEAVE_ERR_MSG : 0; cleanup = 1; part2Ptr = NULL; part1Ptr = OBJ_AT_TOS; /* variable name */ @@ -3913,7 +4256,6 @@ TEBCresume( TRACE_ERROR(interp); goto gotError; } - break; /* * End of INST_UNSET instructions. @@ -3924,20 +4266,20 @@ TEBCresume( const char *msgPart; case INST_CONST_IMM: - opnd = TclGetUInt4AtPtr(pc+1); + varIdx = TclGetUInt4AtPtr(pc + 1); pcAdjustment = 5; cleanup = 1; part1Ptr = NULL; objPtr = OBJ_AT_TOS; - TRACE(("%u \"%.30s\" => \n", opnd, O2S(objPtr))); - varPtr = LOCAL(opnd); + TRACE(("%u \"%.30s\" => \n", (unsigned) varIdx, O2S(objPtr))); + varPtr = LOCAL(varIdx); arrayPtr = NULL; while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } goto doConst; case INST_CONST_STK: - opnd = -1; + varIdx = -1; pcAdjustment = 1; cleanup = 2; part1Ptr = OBJ_UNDER_TOS; @@ -3947,7 +4289,7 @@ TEBCresume( /*createPart1*/1, /*createPart2*/0, &arrayPtr); doConst: if (TclIsVarConstant(varPtr)) { - TRACE_APPEND(("\n")); + TRACE_APPEND(("already constant\n")); NEXT_INST_V(pcAdjustment, cleanup, 0); } if (TclIsVarArray(varPtr)) { @@ -3964,11 +4306,9 @@ TEBCresume( varPtr->value.objPtr = objPtr; Tcl_IncrRefCount(objPtr); } else { - Tcl_Obj *resPtr; - DECACHE_STACK_INFO(); - resPtr = TclPtrSetVarIdx(interp, varPtr, arrayPtr, part1Ptr, NULL, - objPtr, TCL_LEAVE_ERR_MSG, opnd); + Tcl_Obj *resPtr = TclPtrSetVarIdx(interp, varPtr, arrayPtr, + part1Ptr, NULL, objPtr, TCL_LEAVE_ERR_MSG, varIdx); CACHE_STACK_INFO(); if (resPtr == NULL) { TRACE_ERROR(interp); @@ -3980,8 +4320,10 @@ TEBCresume( NEXT_INST_V(pcAdjustment, cleanup, 0); constError: - TclObjVarErrMsg(interp, part1Ptr, NULL, "make constant", msgPart, opnd); + TclObjVarErrMsg(interp, part1Ptr, NULL, "make constant", msgPart, varIdx); + DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CONST", (char *)NULL); + CACHE_STACK_INFO(); TRACE_ERROR(interp); goto gotError; } @@ -3993,19 +4335,19 @@ TEBCresume( */ case INST_ARRAY_EXISTS_IMM: - opnd = TclGetUInt4AtPtr(pc+1); + varIdx = TclGetUInt4AtPtr(pc + 1); pcAdjustment = 5; cleanup = 0; part1Ptr = NULL; arrayPtr = NULL; - TRACE(("%u => ", opnd)); - varPtr = LOCAL(opnd); + TRACE(("%u => ", (unsigned)varIdx)); + varPtr = LOCAL(varIdx); while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } goto doArrayExists; case INST_ARRAY_EXISTS_STK: - opnd = -1; + varIdx = -1; pcAdjustment = 1; cleanup = 1; part1Ptr = OBJ_AT_TOS; @@ -4014,7 +4356,7 @@ TEBCresume( /*createPart1*/0, /*createPart2*/0, &arrayPtr); doArrayExists: DECACHE_STACK_INFO(); - result = TclCheckArrayTraces(interp, varPtr, arrayPtr, part1Ptr, opnd); + result = TclCheckArrayTraces(interp, varPtr, arrayPtr, part1Ptr, varIdx); CACHE_STACK_INFO(); if (result == TCL_ERROR) { TRACE_ERROR(interp); @@ -4025,23 +4367,23 @@ TEBCresume( } else { objResultPtr = TCONST(0); } - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + TRACE_APPEND_OBJ(objResultPtr); NEXT_INST_V(pcAdjustment, cleanup, 1); case INST_ARRAY_MAKE_IMM: - opnd = TclGetUInt4AtPtr(pc+1); + varIdx = TclGetUInt4AtPtr(pc + 1); pcAdjustment = 5; cleanup = 0; part1Ptr = NULL; arrayPtr = NULL; - TRACE(("%u => ", opnd)); - varPtr = LOCAL(opnd); + TRACE(("%u => ", (unsigned)varIdx)); + varPtr = LOCAL(varIdx); while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } goto doArrayMake; case INST_ARRAY_MAKE_STK: - opnd = -1; + varIdx = -1; pcAdjustment = 1; cleanup = 1; part1Ptr = OBJ_AT_TOS; @@ -4060,7 +4402,7 @@ TEBCresume( */ TclObjVarErrMsg(interp, part1Ptr, NULL, "array set", - "variable isn't array", opnd); + "variable isn't array", varIdx); DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", (char *)NULL); CACHE_STACK_INFO(); @@ -4089,7 +4431,7 @@ TEBCresume( Namespace *savedNsPtr; case INST_UPVAR: - TRACE(("%d %.30s %.30s => ", TclGetInt4AtPtr(pc+1), + TRACE(("%u %.30s %.30s => ", TclGetUInt4AtPtr(pc + 1), O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS))); if (TclObjGetFrame(interp, OBJ_UNDER_TOS, &framePtr) == -1) { @@ -4114,7 +4456,7 @@ TEBCresume( goto doLinkVars; case INST_NSUPVAR: - TRACE(("%d %.30s %.30s => ", TclGetInt4AtPtr(pc+1), + TRACE(("%u %.30s %.30s => ", TclGetUInt4AtPtr(pc + 1), O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS))); if (TclGetNamespaceFromObj(interp, OBJ_UNDER_TOS, &nsPtr) != TCL_OK) { TRACE_ERROR(interp); @@ -4138,7 +4480,7 @@ TEBCresume( goto doLinkVars; case INST_VARIABLE: - TRACE(("%d, %.30s => ", TclGetInt4AtPtr(pc+1), O2S(OBJ_AT_TOS))); + TRACE(("%u, %.30s => ", TclGetUInt4AtPtr(pc + 1), O2S(OBJ_AT_TOS))); otherPtr = TclObjLookupVarEx(interp, OBJ_AT_TOS, NULL, (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "access", /*createPart1*/ 1, /*createPart2*/ 1, &varPtr); @@ -4161,8 +4503,8 @@ TEBCresume( * if there are no errors; otherwise, let it handle the case. */ - opnd = TclGetInt4AtPtr(pc+1); - varPtr = LOCAL(opnd); + varIdx = TclGetUInt4AtPtr(pc + 1); + varPtr = LOCAL(varIdx); if ((varPtr != otherPtr) && !TclIsVarTraced(varPtr) && (TclIsVarUndefined(varPtr) || TclIsVarLink(varPtr))) { if (!TclIsVarUndefined(varPtr)) { @@ -4174,7 +4516,7 @@ TEBCresume( if (linkPtr == otherPtr) { TRACE_APPEND(("already linked\n")); - NEXT_INST_F(5, 1, 0); + NEXT_INST_F0(5, 1); } if (TclIsVarInHash(linkPtr)) { VarHashRefCount(linkPtr)--; @@ -4189,7 +4531,7 @@ TEBCresume( VarHashRefCount(otherPtr)++; } } else if (TclPtrObjMakeUpvarIdx(interp, otherPtr, NULL, 0, - opnd) != TCL_OK) { + varIdx) != TCL_OK) { TRACE_ERROR(interp); goto gotError; } @@ -4200,56 +4542,63 @@ TEBCresume( */ TRACE_APPEND(("link made\n")); - NEXT_INST_F(5, 1, 0); + NEXT_INST_F0(5, 1); } - break; /* * End of variable linking instructions. * ----------------------------------------------------------------- */ +#ifndef REMOVE_DEPRECATED_OPCODES case INST_JUMP1: - opnd = TclGetInt1AtPtr(pc+1); - TRACE(("%d => new pc %" TCL_Z_MODIFIER "u\n", opnd, - (size_t)(pc + opnd - codePtr->codeStart))); - NEXT_INST_F(opnd, 0, 0); - break; - - case INST_JUMP4: - opnd = TclGetInt4AtPtr(pc+1); - TRACE(("%d => new pc %" TCL_Z_MODIFIER "u\n", opnd, - (size_t)(pc + opnd - codePtr->codeStart))); - NEXT_INST_F(opnd, 0, 0); + DEPRECATED_OPCODE_MARK(INST_JUMP1); + pcAdjustment = TclGetInt1AtPtr(pc + 1); + TRACE(("%d => new pc %" SIZEd "\n", pcAdjustment, + PC_REL + pcAdjustment)); + NEXT_INST_F0(pcAdjustment, 0); +#endif + + case INST_JUMP: + pcAdjustment = TclGetInt4AtPtr(pc + 1); + TRACE(("%d => new pc %" SIZEd "\n", pcAdjustment, + PC_REL + pcAdjustment)); + NEXT_INST_F0(pcAdjustment, 0); { int jmpOffset[2], b; /* TODO: consider rewrite so we don't compute the offset we're not * going to take. */ - case INST_JUMP_FALSE4: - jmpOffset[0] = TclGetInt4AtPtr(pc+1); /* FALSE offset */ - jmpOffset[1] = 5; /* TRUE offset */ - goto doCondJump; - - case INST_JUMP_TRUE4: - jmpOffset[0] = 5; - jmpOffset[1] = TclGetInt4AtPtr(pc+1); - goto doCondJump; - +#ifndef REMOVE_DEPRECATED_OPCODES case INST_JUMP_FALSE1: - jmpOffset[0] = TclGetInt1AtPtr(pc+1); + DEPRECATED_OPCODE_MARK(INST_JUMP_FALSE1); + jmpOffset[0] = TclGetInt1AtPtr(pc + 1); jmpOffset[1] = 2; + TRACE(("%d => ", jmpOffset[0])); goto doCondJump; case INST_JUMP_TRUE1: + DEPRECATED_OPCODE_MARK(INST_JUMP_TRUE1); jmpOffset[0] = 2; - jmpOffset[1] = TclGetInt1AtPtr(pc+1); + jmpOffset[1] = TclGetInt1AtPtr(pc + 1); + TRACE(("%d => ", jmpOffset[1])); + goto doCondJump; +#endif + + case INST_JUMP_FALSE: + jmpOffset[0] = TclGetInt4AtPtr(pc + 1); /* FALSE offset */ + jmpOffset[1] = 5; /* TRUE offset */ + TRACE(("%d => ", jmpOffset[0])); + goto doCondJump; + + case INST_JUMP_TRUE: + jmpOffset[0] = 5; + jmpOffset[1] = TclGetInt4AtPtr(pc + 1); + TRACE(("%d => ", jmpOffset[1])); doCondJump: valuePtr = OBJ_AT_TOS; - TRACE(("%d => ", jmpOffset[ - (*pc==INST_JUMP_FALSE1 || *pc==INST_JUMP_FALSE4) ? 0 : 1])); /* TODO - check claim that taking address of b harms performance */ /* TODO - consider optimization search for constants */ @@ -4260,50 +4609,78 @@ TEBCresume( #ifdef TCL_COMPILE_DEBUG if (b) { - if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE4)) { - TRACE_APPEND(("%.20s true, new pc %" TCL_Z_MODIFIER "u\n", O2S(valuePtr), - (size_t)(pc + jmpOffset[1] - codePtr->codeStart))); + if ((*pc == INST_JUMP_TRUE) +#ifndef REMOVE_DEPRECATED_OPCODES + || (*pc == INST_JUMP_TRUE1) +#endif + ) { + TRACE_APPEND(("%.20s true, new pc %" SIZEd "\n", O2S(valuePtr), + PC_REL + jmpOffset[1])); } else { TRACE_APPEND(("%.20s true\n", O2S(valuePtr))); } } else { - if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE4)) { + if ((*pc == INST_JUMP_TRUE) +#ifndef REMOVE_DEPRECATED_OPCODES + || (*pc == INST_JUMP_TRUE1) +#endif + ) { TRACE_APPEND(("%.20s false\n", O2S(valuePtr))); } else { - TRACE_APPEND(("%.20s false, new pc %" TCL_Z_MODIFIER "u\n", O2S(valuePtr), - (size_t)(pc + jmpOffset[0] - codePtr->codeStart))); + TRACE_APPEND(("%.20s false, new pc %" SIZEd "\n", O2S(valuePtr), + PC_REL + jmpOffset[0])); } } #endif - NEXT_INST_F(jmpOffset[b], 1, 0); + NEXT_INST_F0(jmpOffset[b], 1); } - break; - case INST_JUMP_TABLE: { + { Tcl_HashEntry *hPtr; - JumptableInfo *jtPtr; /* * Jump to location looked up in a hashtable; fall through to next - * instr if lookup fails. + * instr if lookup fails. Lookup by string. */ - opnd = TclGetInt4AtPtr(pc+1); - jtPtr = (JumptableInfo *) codePtr->auxDataArrayPtr[opnd].clientData; - TRACE(("%d \"%.20s\" => ", opnd, O2S(OBJ_AT_TOS))); + case INST_JUMP_TABLE: + tblIdx = TclGetInt4AtPtr(pc + 1); + JumptableInfo *jtPtr = (JumptableInfo *) + codePtr->auxDataArrayPtr[tblIdx].clientData; + TRACE(("%u \"%.20s\" => ", tblIdx, O2S(OBJ_AT_TOS))); hPtr = Tcl_FindHashEntry(&jtPtr->hashTable, TclGetString(OBJ_AT_TOS)); + goto processJumpTableEntry; + + /* + * Jump to location looked up in a hashtable; fall through to next + * instr if lookup fails or key is non-integer. Lookup by integer. + */ + + case INST_JUMP_TABLE_NUM: + tblIdx = TclGetInt4AtPtr(pc + 1); + JumptableNumInfo *jtnPtr = (JumptableNumInfo *) + codePtr->auxDataArrayPtr[tblIdx].clientData; + TRACE(("%u \"%.20s\" => ", tblIdx, O2S(OBJ_AT_TOS))); + DECACHE_STACK_INFO(); + Tcl_WideInt key; + if (Tcl_GetWideIntFromObj(interp, OBJ_AT_TOS, &key) != TCL_OK) { + TRACE_ERROR(interp); + goto gotError; + } + CACHE_STACK_INFO(); + hPtr = Tcl_FindHashEntry(&jtnPtr->hashTable, INT2PTR(key)); + + processJumpTableEntry: if (hPtr != NULL) { Tcl_Size jumpOffset = PTR2INT(Tcl_GetHashValue(hPtr)); - TRACE_APPEND(("found in table, new pc %" TCL_Z_MODIFIER "u\n", - (size_t)(pc - codePtr->codeStart + jumpOffset))); - NEXT_INST_F(jumpOffset, 1, 0); - } else { - TRACE_APPEND(("not found in table\n")); - NEXT_INST_F(5, 1, 0); + TRACE_APPEND(("found in table, new pc %" SIZEu "\n", + PC_REL + jumpOffset)); + NEXT_INST_F0(jumpOffset, 1); } + TRACE_APPEND(("not found in table\n")); + NEXT_INST_F0(5, 1); } - break; /* * ----------------------------------------------------------------- @@ -4314,7 +4691,6 @@ TEBCresume( objResultPtr = TclNewNamespaceObj(TclGetCurrentNamespace(interp)); TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(1, 0, 1); - break; case INST_COROUTINE_NAME: { CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; @@ -4326,19 +4702,17 @@ TEBCresume( TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(1, 0, 1); } - break; case INST_INFO_LEVEL_NUM: TclNewIntObj(objResultPtr, (int)iPtr->varFramePtr->level); TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(1, 0, 1); - break; case INST_INFO_LEVEL_ARGS: { - int level; + Tcl_WideInt level; CallFrame *framePtr = iPtr->varFramePtr; CallFrame *rootFramePtr = iPtr->rootFramePtr; TRACE(("\"%.30s\" => ", O2S(OBJ_AT_TOS))); - if (TclGetIntFromObj(interp, OBJ_AT_TOS, &level) != TCL_OK) { + if (TclGetWideIntFromObj(interp, OBJ_AT_TOS, &level) != TCL_OK) { TRACE_ERROR(interp); goto gotError; } @@ -4360,7 +4734,7 @@ TEBCresume( goto gotError; } objResultPtr = Tcl_NewListObj(framePtr->objc, framePtr->objv); - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + TRACE_APPEND_OBJ(objResultPtr); NEXT_INST_F(1, 1, 1); } { @@ -4400,7 +4774,7 @@ TEBCresume( TRACE_APPEND(("ERROR: not command\n")); goto gotError; } - TRACE_APPEND(("\"%.30s\"", O2S(OBJ_AT_TOS))); + TRACE_APPEND_OBJ(OBJ_AT_TOS); NEXT_INST_F(1, 1, 1); } @@ -4411,14 +4785,13 @@ TEBCresume( { Object *oPtr; - CallFrame *framePtr; + Class *clsPtr; CallContext *contextPtr; Tcl_Size skip, newDepth; case INST_TCLOO_SELF: - framePtr = iPtr->varFramePtr; - if (framePtr == NULL || - !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { + contextPtr = GetTclOOCallContext(iPtr); + if (!contextPtr) { TRACE(("=> ERROR: no TclOO call context\n")); Tcl_SetObjResult(interp, Tcl_NewStringObj( "self may only be called from inside a method", @@ -4428,7 +4801,6 @@ TEBCresume( CACHE_STACK_INFO(); goto gotError; } - contextPtr = (CallContext *)framePtr->clientData; /* * Call out to get the name; it's expensive to compute but cached. @@ -4438,124 +4810,92 @@ TEBCresume( TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(1, 0, 1); + case INST_TCLOO_NEXT_CLASS_LIST: + if (TclListObjGetElements(NULL, valuePtr, &numArgs, &objv) != TCL_OK) { + Tcl_Panic("ill-formed call to [nextto]"); + } + if (numArgs < 2) { + Tcl_Panic("insufficient words to [nextto]"); + } + cleanup = 1; + pcAdjustment = 1; + valuePtr = objv[1]; + TRACE(("=> ")); + goto invokeNextClass; +#ifndef REMOVE_DEPRECATED_OPCODES + case INST_TCLOO_NEXT_CLASS1: + DEPRECATED_OPCODE_MARK(INST_TCLOO_NEXT_CLASS1); + numArgs = TclGetUInt1AtPtr(pc + 1); + cleanup = numArgs; + pcAdjustment = 2; + valuePtr = OBJ_AT_DEPTH(numArgs - 2); + objv = &OBJ_AT_DEPTH(numArgs - 1); + TRACE(("%u => ", (unsigned)numArgs)); + goto invokeNextClass; +#endif case INST_TCLOO_NEXT_CLASS: - opnd = TclGetUInt1AtPtr(pc+1); - framePtr = iPtr->varFramePtr; - valuePtr = OBJ_AT_DEPTH(opnd - 2); - objv = &OBJ_AT_DEPTH(opnd - 1); + numArgs = TclGetUInt4AtPtr(pc + 1); + cleanup = numArgs; + pcAdjustment = 5; + valuePtr = OBJ_AT_DEPTH(numArgs - 2); + objv = &OBJ_AT_DEPTH(numArgs - 1); + TRACE(("%u => ", (unsigned)numArgs)); + invokeNextClass: skip = 2; - TRACE(("%d => ", opnd)); - if (framePtr == NULL || - !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { - TRACE_APPEND(("ERROR: no TclOO call context\n")); - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "nextto may only be called from inside a method", - -1)); - DECACHE_STACK_INFO(); - OO_ERROR(interp, CONTEXT_REQUIRED); - CACHE_STACK_INFO(); - goto gotError; + contextPtr = GetTclOOCallContext(iPtr); + if (!contextPtr) { + goto tclooFrameRequired; } - contextPtr = (CallContext *)framePtr->clientData; - - oPtr = (Object *) Tcl_GetObjectFromObj(interp, valuePtr); - if (oPtr == NULL) { - TRACE_APPEND(("ERROR: \"%.30s\" not object\n", O2S(valuePtr))); - goto gotError; - } else { - Class *classPtr = oPtr->classPtr; - struct MInvoke *miPtr; - Tcl_Size i; - const char *methodType; - - if (classPtr == NULL) { - TRACE_APPEND(("ERROR: \"%.30s\" not class\n", O2S(valuePtr))); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "\"%s\" is not a class", TclGetString(valuePtr))); - DECACHE_STACK_INFO(); - OO_ERROR(interp, CLASS_REQUIRED); - CACHE_STACK_INFO(); - goto gotError; - } - - for (i=contextPtr->index+1 ; i<contextPtr->callPtr->numChain ; i++) { - miPtr = contextPtr->callPtr->chain + i; - if (!miPtr->isFilter && - miPtr->mPtr->declaringClassPtr == classPtr) { - newDepth = i; -#ifdef TCL_COMPILE_DEBUG - if (tclTraceExec >= 2) { - if (traceInstructions) { - strncpy(cmdNameBuf, TclGetString(objv[0]), 20); - } else { - fprintf(stdout, "%" TCL_SIZE_MODIFIER "d: (%" TCL_T_MODIFIER "d) invoking ", - iPtr->numLevels, - (size_t)(pc - codePtr->codeStart)); - } - for (i = 0; i < opnd; i++) { - TclPrintObject(stdout, objv[i], 15); - fprintf(stdout, " "); - } - fprintf(stdout, "\n"); - fflush(stdout); - } -#endif /*TCL_COMPILE_DEBUG*/ - goto doInvokeNext; - } - } - - if (contextPtr->callPtr->flags & CONSTRUCTOR) { - methodType = "constructor"; - } else if (contextPtr->callPtr->flags & DESTRUCTOR) { - methodType = "destructor"; - } else { - methodType = "method"; - } - TRACE_APPEND(("ERROR: \"%.30s\" not on reachable chain\n", - O2S(valuePtr))); - for (i = contextPtr->index ; i != TCL_INDEX_NONE ; i--) { - miPtr = contextPtr->callPtr->chain + i; - if (miPtr->isFilter - || miPtr->mPtr->declaringClassPtr != classPtr) { - continue; - } - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "%s implementation by \"%s\" not reachable from here", - methodType, TclGetString(valuePtr))); - DECACHE_STACK_INFO(); - OO_ERROR(interp, CLASS_NOT_REACHABLE); - CACHE_STACK_INFO(); - goto gotError; - } - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "%s has no non-filter implementation by \"%s\"", - methodType, TclGetString(valuePtr))); - DECACHE_STACK_INFO(); - OO_ERROR(interp, CLASS_NOT_THERE); + DECACHE_STACK_INFO(); + clsPtr = TclOOGetClassFromObj(interp, valuePtr); + if (clsPtr == NULL) { + TRACE_APPEND(("ERROR: \"%.30s\" not class\n", O2S(valuePtr))); CACHE_STACK_INFO(); goto gotError; } + newDepth = FindTclOOMethodIndex(contextPtr, clsPtr); + if (newDepth == TCL_INDEX_NONE) { + goto tclooNoTargetClass; + } + goto doInvokeNext; + case INST_TCLOO_NEXT_LIST: + valuePtr = OBJ_AT_TOS; + if (TclListObjGetElements(NULL, valuePtr, &numArgs, &objv) != TCL_OK) { + Tcl_Panic("ill-formed call to [next]"); + } + if (numArgs < 1) { + Tcl_Panic("insufficient words to [next]"); + } + pcAdjustment = 1; + cleanup = 1; + TRACE(("=> ")); + goto invokeNext; +#ifndef REMOVE_DEPRECATED_OPCODES + case INST_TCLOO_NEXT1: + DEPRECATED_OPCODE_MARK(INST_TCLOO_NEXT1); + numArgs = TclGetUInt1AtPtr(pc + 1); + pcAdjustment = 2; + cleanup = numArgs; + objv = &OBJ_AT_DEPTH(numArgs - 1); + TRACE(("%u => ", (unsigned)numArgs)); + goto invokeNext; +#endif case INST_TCLOO_NEXT: - opnd = TclGetUInt1AtPtr(pc+1); - objv = &OBJ_AT_DEPTH(opnd - 1); - framePtr = iPtr->varFramePtr; + numArgs = TclGetUInt4AtPtr(pc + 1); + pcAdjustment = 5; + cleanup = numArgs; + objv = &OBJ_AT_DEPTH(numArgs - 1); + TRACE(("%u => ", (unsigned)numArgs)); + invokeNext: skip = 1; - TRACE(("%d => ", opnd)); - if (framePtr == NULL || - !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { - TRACE_APPEND(("ERROR: no TclOO call context\n")); - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "next may only be called from inside a method", - -1)); - DECACHE_STACK_INFO(); - OO_ERROR(interp, CONTEXT_REQUIRED); - CACHE_STACK_INFO(); - goto gotError; + contextPtr = GetTclOOCallContext(iPtr); + if (!contextPtr) { + goto tclooFrameRequired; } - contextPtr = (CallContext *)framePtr->clientData; + DECACHE_STACK_INFO(); newDepth = contextPtr->index + 1; if (newDepth >= contextPtr->callPtr->numChain) { /* @@ -4564,113 +4904,146 @@ TEBCresume( * getting here because of methods/destructors doing a [next] (or * equivalent) unexpectedly. */ + goto tclooNoNext; + } - const char *methodType; - - if (contextPtr->callPtr->flags & CONSTRUCTOR) { - methodType = "constructor"; - } else if (contextPtr->callPtr->flags & DESTRUCTOR) { - methodType = "destructor"; - } else { - methodType = "method"; - } - - TRACE_APPEND(("ERROR: no TclOO next impl\n")); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "no next %s implementation", methodType)); - DECACHE_STACK_INFO(); - OO_ERROR(interp, NOTHING_NEXT); - CACHE_STACK_INFO(); - goto gotError; + doInvokeNext: #ifdef TCL_COMPILE_DEBUG - } else if (tclTraceExec >= 2) { - int i; - + if (tclTraceExec >= TCL_TRACE_BYTECODE_EXEC_COMMANDS) { if (traceInstructions) { strncpy(cmdNameBuf, TclGetString(objv[0]), 20); } else { - fprintf(stdout, "%" TCL_SIZE_MODIFIER "d: (%" TCL_Z_MODIFIER "u) invoking ", - iPtr->numLevels, (pc - codePtr->codeStart)); - } - for (i = 0; i < opnd; i++) { - TclPrintObject(stdout, objv[i], 15); - fprintf(stdout, " "); + fprintf(stdout, "%" SIZEd ": (%" SIZEd ") invoking ", + iPtr->numLevels, PC_REL); } + PrintArgumentWords(numArgs, objv); fprintf(stdout, "\n"); fflush(stdout); -#endif /*TCL_COMPILE_DEBUG*/ } - - doInvokeNext: +#endif // TCL_COMPILE_DEBUG bcFramePtr->data.tebc.pc = (char *) pc; iPtr->cmdFramePtr = bcFramePtr; if (iPtr->flags & INTERP_DEBUG_FRAME) { - ArgumentBCEnter(interp, codePtr, TD, pc, opnd, objv); + ArgumentBCEnter(interp, codePtr, TD, pc, numArgs, objv); } - pcAdjustment = 2; - cleanup = opnd; - DECACHE_STACK_INFO(); - iPtr->varFramePtr = framePtr->callerVarPtr; + // Arrange for where to go after [next] returns pc += pcAdjustment; TEBC_YIELD(); - TclPushTailcallPoint(interp); - oPtr = contextPtr->oPtr; - if (oPtr->flags & FILTER_HANDLING) { - TclNRAddCallback(interp, FinalizeOONextFilter, - framePtr, contextPtr, INT2PTR(contextPtr->index), - INT2PTR(contextPtr->skip)); - } else { - TclNRAddCallback(interp, FinalizeOONext, + { + // [next] and [nextto] are uplevel-like + CallFrame *framePtr = iPtr->varFramePtr; + iPtr->varFramePtr = framePtr->callerVarPtr; + oPtr = contextPtr->oPtr; + + // Adjust filter flags + Tcl_NRPostProc *callback = (oPtr->flags & FILTER_HANDLING) + ? FinalizeOONextFilter : FinalizeOONext; + if (contextPtr->callPtr->chain[newDepth].isFilter + || contextPtr->callPtr->flags & FILTER_HANDLING) { + oPtr->flags |= FILTER_HANDLING; + } else { + oPtr->flags &= ~FILTER_HANDLING; + } + + // Arrange for things to be restored in the object + TclPushTailcallPoint(interp); + TclNRAddCallback(interp, callback, framePtr, contextPtr, INT2PTR(contextPtr->index), INT2PTR(contextPtr->skip)); - } - contextPtr->skip = skip; - contextPtr->index = newDepth; - if (contextPtr->callPtr->chain[newDepth].isFilter - || contextPtr->callPtr->flags & FILTER_HANDLING) { - oPtr->flags |= FILTER_HANDLING; - } else { - oPtr->flags &= ~FILTER_HANDLING; - } - { - Method *const mPtr = - contextPtr->callPtr->chain[newDepth].mPtr; + // Update the context fields to point to the next impl + contextPtr->skip = skip; + contextPtr->index = newDepth; + // Call the selected next method non-recursively + const Method *mPtr = contextPtr->callPtr->chain[newDepth].mPtr; if (mPtr->typePtr->version < TCL_OO_METHOD_VERSION_2) { return mPtr->typePtr->callProc(mPtr->clientData, interp, - (Tcl_ObjectContext) contextPtr, opnd, objv); + (Tcl_ObjectContext) contextPtr, (int)numArgs, objv); } - return ((Tcl_MethodCallProc2 *)(void *)(mPtr->typePtr->callProc))(mPtr->clientData, interp, - (Tcl_ObjectContext) contextPtr, opnd, objv); + return mPtr->type2Ptr->callProc(mPtr->clientData, interp, + (Tcl_ObjectContext) contextPtr, numArgs, objv); } + tclooFrameRequired: + TRACE_APPEND(("ERROR: no TclOO call context\n")); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s may only be called from inside a method", + TclGetString(objv[0]))); + DECACHE_STACK_INFO(); + OO_ERROR(interp, CONTEXT_REQUIRED); + CACHE_STACK_INFO(); + goto gotError; + tclooNoNext: + TRACE_APPEND(("ERROR: no TclOO next impl\n")); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "no next %s implementation", TclOOContextTypeName(contextPtr))); + OO_ERROR(interp, NOTHING_NEXT); + CACHE_STACK_INFO(); + goto gotError; + tclooNoTargetClass: + TRACE_APPEND(("ERROR: \"%.30s\" not on reachable chain\n", + O2S(valuePtr))); + // Decide what error message to issue + for (Tcl_Size i = contextPtr->index ; i >= 0 ; i--) { + MInvoke *miPtr = contextPtr->callPtr->chain + i; + if (miPtr->isFilter) { + /* Filters are always at the head of the chain, and we never + * want them at this point. */ + break; + } + if (miPtr->mPtr->declaringClassPtr == clsPtr) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s implementation by \"%s\" not reachable from here", + TclOOContextTypeName(contextPtr), + TclGetString(valuePtr))); + OO_ERROR(interp, CLASS_NOT_REACHABLE); + CACHE_STACK_INFO(); + goto gotError; + } + } + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s has no non-filter implementation by \"%s\"", + TclOOContextTypeName(contextPtr), TclGetString(valuePtr))); + OO_ERROR(interp, CLASS_NOT_THERE); + CACHE_STACK_INFO(); + goto gotError; + case INST_TCLOO_IS_OBJECT: + TRACE(("\"%.30s\" => ", O2S(OBJ_AT_TOS))); + DECACHE_STACK_INFO(); oPtr = (Object *) Tcl_GetObjectFromObj(interp, OBJ_AT_TOS); - objResultPtr = TCONST(oPtr != NULL ? 1 : 0); - TRACE_WITH_OBJ(("%.30s => ", O2S(OBJ_AT_TOS)), objResultPtr); - NEXT_INST_F(1, 1, 1); + CACHE_STACK_INFO(); + int match = oPtr != NULL; + TRACE_APPEND(("%d\n", match)); + JUMP_PEEPHOLE_F(match, 1, 1); case INST_TCLOO_CLASS: - oPtr = (Object *) Tcl_GetObjectFromObj(interp, OBJ_AT_TOS); - if (oPtr == NULL) { - TRACE(("%.30s => ERROR: not object\n", O2S(OBJ_AT_TOS))); - goto gotError; - } - objResultPtr = TclOOObjectName(interp, oPtr->selfCls->thisPtr); - TRACE_WITH_OBJ(("%.30s => ", O2S(OBJ_AT_TOS)), objResultPtr); - NEXT_INST_F(1, 1, 1); case INST_TCLOO_NS: + case INST_TCLOO_ID: + DECACHE_STACK_INFO(); oPtr = (Object *) Tcl_GetObjectFromObj(interp, OBJ_AT_TOS); + CACHE_STACK_INFO(); if (oPtr == NULL) { - TRACE(("%.30s => ERROR: not object\n", O2S(OBJ_AT_TOS))); + TRACE(("\"%.30s\" => ERROR: not object\n", O2S(OBJ_AT_TOS))); goto gotError; } - - objResultPtr = TclNewNamespaceObj(oPtr->namespacePtr); - TRACE_WITH_OBJ(("%.30s => ", O2S(OBJ_AT_TOS)), objResultPtr); + switch (inst) { + case INST_TCLOO_CLASS: + objResultPtr = TclOOObjectName(interp, oPtr->selfCls->thisPtr); + break; + case INST_TCLOO_NS: + objResultPtr = TclNewNamespaceObj(oPtr->namespacePtr); + break; + case INST_TCLOO_ID: + objResultPtr = Tcl_NewWideIntObj(oPtr->creationEpoch); + break; + default: + TCL_UNREACHABLE(); + } + TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(OBJ_AT_TOS)), objResultPtr); NEXT_INST_F(1, 1, 1); } @@ -4681,20 +5054,20 @@ TEBCresume( */ { - int numIndices, nocase, match, cflags; - Tcl_Size slength, length2, fromIdx, toIdx, index, s1len, s2len; + int nocase, match, fromIdxEnc, toIdxEnc; + Tcl_Size slength, length2, fromIdx, toIdx, index, s1len, s2len, numIndices; const char *s1, *s2; case INST_LIST: /* - * Pop the opnd (objc) top stack elements into a new list obj and then + * Pop the numArgs (objc) top stack elements into a new list obj and then * decrement their ref counts. */ - opnd = TclGetUInt4AtPtr(pc+1); - objResultPtr = Tcl_NewListObj(opnd, &OBJ_AT_DEPTH(opnd-1)); - TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); - NEXT_INST_V(5, opnd, 1); + numArgs = TclGetUInt4AtPtr(pc + 1); + objResultPtr = Tcl_NewListObj(numArgs, &OBJ_AT_DEPTH(numArgs - 1)); + TRACE_WITH_OBJ(("%u => ", (unsigned) numArgs), objResultPtr); + NEXT_INST_V(5, numArgs, 1); case INST_LIST_LENGTH: TRACE(("\"%.30s\" => ", O2S(OBJ_AT_TOS))); @@ -4703,7 +5076,7 @@ TEBCresume( goto gotError; } TclNewIntObj(objResultPtr, length); - TRACE_APPEND(("%" TCL_SIZE_MODIFIER "d\n", length)); + TRACE_APPEND(("%" SIZEd "\n", length)); NEXT_INST_F(1, 1, 1); case INST_LIST_INDEX: /* lindex with objc == 3 */ @@ -4744,15 +5117,13 @@ TEBCresume( value2Length == 1 ? (indexListPtr = TclListObjGetElement(value2Ptr, 0), 1) : 0))) { - int code; - /* increment the refCount of value2Ptr because TclListObjGetElement may * have just extracted it from a list in the condition for this block. */ Tcl_IncrRefCount(indexListPtr); DECACHE_STACK_INFO(); - code = TclGetIntForIndexM(interp, indexListPtr, objc-1, &index); + int code = TclGetIntForIndexM(interp, indexListPtr, objc - 1, &index); TclDecrRefCount(indexListPtr); CACHE_STACK_INFO(); if (code == TCL_OK) { @@ -4779,10 +5150,10 @@ TEBCresume( * Stash the list element on the stack. */ - TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); + TRACE_APPEND_OBJ(objResultPtr); NEXT_INST_F(1, 2, -1); /* Already has the correct refCount */ - case INST_LIST_INDEX_IMM: /* lindex with objc==3 and index in bytecode + case INST_LIST_INDEX_IMM: { /* lindex with objc==3 and index in bytecode * stream */ /* @@ -4790,8 +5161,8 @@ TEBCresume( */ valuePtr = OBJ_AT_TOS; - opnd = TclGetInt4AtPtr(pc+1); - TRACE(("\"%.30s\" %d => ", O2S(valuePtr), opnd)); + int encIndex = TclGetInt4AtPtr(pc + 1); + TRACE(("\"%.30s\" %d => ", O2S(valuePtr), encIndex)); /* * Get the contents of the list, making sure that it really is a list @@ -4803,17 +5174,17 @@ TEBCresume( length = TclObjTypeLength(valuePtr); /* Decode end-offset index values. */ - index = TclIndexDecode(opnd, length-1); + index = TclIndexDecode(encIndex, length - 1); if (index >= 0 && index < length) { /* Compute value @ index */ DECACHE_STACK_INFO(); - if (TclObjTypeIndex(interp, valuePtr, index, &objResultPtr)!=TCL_OK) { - CACHE_STACK_INFO(); + int code = TclObjTypeIndex(interp, valuePtr, index, &objResultPtr); + CACHE_STACK_INFO(); + if (code != TCL_OK) { TRACE_ERROR(interp); goto gotError; } - CACHE_STACK_INFO(); } else { TclNewObj(objResultPtr); } @@ -4830,7 +5201,7 @@ TEBCresume( /* Decode end-offset index values. */ - index = TclIndexDecode(opnd, objc - 1); + index = TclIndexDecode(encIndex, objc - 1); pcAdjustment = 5; lindexFastPath: @@ -4841,23 +5212,23 @@ TEBCresume( } lindexFastPath2: - - TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); + TRACE_APPEND_OBJ(objResultPtr); NEXT_INST_F(pcAdjustment, 1, 1); + } case INST_LIST_INDEX_MULTI: /* 'lindex' with multiple index args */ /* * Determine the count of index args. */ - opnd = TclGetUInt4AtPtr(pc+1); - numIndices = opnd-1; + numArgs = TclGetUInt4AtPtr(pc + 1); + numIndices = numArgs - 1; /* * Do the 'lindex' operation. */ - TRACE(("%d => ", opnd)); + TRACE(("%u => ", (unsigned)numArgs)); objResultPtr = TclLindexFlat(interp, OBJ_AT_DEPTH(numIndices), numIndices, &OBJ_AT_DEPTH(numIndices - 1)); if (!objResultPtr) { @@ -4869,17 +5240,17 @@ TEBCresume( * Set result. */ - TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); - NEXT_INST_V(5, opnd, -1); + TRACE_APPEND_OBJ(objResultPtr); + NEXT_INST_V(5, numArgs, -1); case INST_LSET_FLAT: /* * Lset with 3, 5, or more args. Get the number of index args. */ - opnd = TclGetUInt4AtPtr(pc + 1); - numIndices = opnd - 2; - TRACE(("%d => ", opnd)); + numArgs = TclGetUInt4AtPtr(pc + 1); + numIndices = numArgs - 2; + TRACE(("%u => ", (unsigned)numArgs)); /* * Get the old value of variable, and remove the stack ref. This is @@ -4904,8 +5275,8 @@ TEBCresume( objResultPtr = TclLsetFlat(interp, valuePtr, numIndices, &OBJ_AT_DEPTH(numIndices), OBJ_AT_TOS); } + CACHE_STACK_INFO(); if (!objResultPtr) { - CACHE_STACK_INFO(); TRACE_ERROR(interp); goto gotError; } @@ -4913,9 +5284,8 @@ TEBCresume( /* * Set result. */ - CACHE_STACK_INFO(); - TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); - NEXT_INST_V(5, numIndices+1, -1); + TRACE_APPEND_OBJ(objResultPtr); + NEXT_INST_V(5, numIndices + 1, -1); case INST_LSET_LIST: /* 'lset' with 4 args */ /* @@ -4951,7 +5321,7 @@ TEBCresume( * Set result. */ - TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); + TRACE_APPEND_OBJ(objResultPtr); NEXT_INST_F(1, 2, -1); case INST_LIST_RANGE_IMM: /* lrange with objc==4 and both indices in @@ -4962,10 +5332,9 @@ TEBCresume( */ valuePtr = OBJ_AT_TOS; - fromIdx = TclGetInt4AtPtr(pc+1); - toIdx = TclGetInt4AtPtr(pc+5); - TRACE(("\"%.30s\" %d %d => ", O2S(valuePtr), TclGetInt4AtPtr(pc+1), - TclGetInt4AtPtr(pc+5))); + fromIdxEnc = TclGetInt4AtPtr(pc + 1); + toIdxEnc = TclGetInt4AtPtr(pc + 5); + TRACE(("\"%.30s\" %d %d => ", O2S(valuePtr), fromIdxEnc, toIdxEnc)); /* * Get the length of the list, making sure that it really is a list @@ -4984,7 +5353,7 @@ TEBCresume( #ifndef TCL_COMPILE_DEBUG if (pc[9] == INST_POP) { - NEXT_INST_F(10, 1, 0); + NEXT_INST_F0(10, 1); } #endif @@ -4993,20 +5362,20 @@ TEBCresume( /* avoid return of not canonical list (e. g. spaces in string repr.) */ if (!valuePtr->bytes || !valuePtr->length) { TRACE_APPEND(("\n")); - NEXT_INST_F(9, 0, 0); + NEXT_INST_F0(9, 0); } goto emptyList; } /* Decode index value operands. */ - if (toIdx == TCL_INDEX_NONE) { + if (toIdxEnc == -1) { emptyList: TclNewObj(objResultPtr); - TRACE_APPEND(("\"%.30s\"", O2S(objResultPtr))); + TRACE_APPEND_OBJ(objResultPtr); NEXT_INST_F(9, 1, 1); } - toIdx = TclIndexDecode(toIdx, objc - 1); + toIdx = TclIndexDecode(toIdxEnc, objc - 1); if (toIdx == TCL_INDEX_NONE) { goto emptyList; } else if (toIdx >= objc) { @@ -5015,32 +5384,25 @@ TEBCresume( assert (toIdx >= 0 && toIdx < objc); /* - assert ( fromIdx != TCL_INDEX_NONE ); + assert ( fromIdxEnc != TCL_INDEX_NONE ); * * Extra safety for legacy bytecodes: */ - if (fromIdx == TCL_INDEX_NONE) { - fromIdx = TCL_INDEX_START; + if (fromIdxEnc == -1) { + fromIdxEnc = 0; } - fromIdx = TclIndexDecode(fromIdx, objc - 1); + fromIdx = TclIndexDecode(fromIdxEnc, objc - 1); DECACHE_STACK_INFO(); - if (TclObjTypeHasProc(valuePtr, sliceProc)) { - if (TclObjTypeSlice(interp, valuePtr, fromIdx, toIdx, &objResultPtr) != TCL_OK) { - objResultPtr = NULL; - } - } else { - objResultPtr = TclListObjRange(interp, valuePtr, fromIdx, toIdx); - } - if (objResultPtr == NULL) { - CACHE_STACK_INFO(); + if (Tcl_ListObjRange(interp, valuePtr, fromIdx, toIdx, + &objResultPtr) != TCL_OK) { + objResultPtr = NULL; TRACE_ERROR(interp); goto gotError; } - CACHE_STACK_INFO(); - TRACE_APPEND(("\"%.30s\"", O2S(objResultPtr))); + TRACE_APPEND_OBJ(objResultPtr); NEXT_INST_F(9, 1, 1); case INST_LIST_IN: @@ -5058,7 +5420,6 @@ TEBCresume( goto gotError; } } else { - if (TclListObjLength(interp, value2Ptr, &length) != TCL_OK) { TRACE_ERROR(interp); goto gotError; @@ -5066,7 +5427,6 @@ TEBCresume( match = 0; if (length > 0) { Tcl_Size i = 0; - Tcl_Obj *o; int isAbstractList = TclObjTypeHasProc(value2Ptr, indexProc) != NULL; /* @@ -5074,14 +5434,15 @@ TEBCresume( */ do { + Tcl_Obj *o; if (isAbstractList) { DECACHE_STACK_INFO(); - if (TclObjTypeIndex(interp, value2Ptr, i, &o) != TCL_OK) { - CACHE_STACK_INFO(); + int status = TclObjTypeIndex(interp, value2Ptr, i, &o); + CACHE_STACK_INFO(); + if (status != TCL_OK) { TRACE_ERROR(interp); goto gotError; } - CACHE_STACK_INFO(); } else { Tcl_ListObjIndex(NULL, value2Ptr, i, &o); } @@ -5129,57 +5490,63 @@ TEBCresume( TclDecrRefCount(objResultPtr); goto gotError; } - TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); + TRACE_APPEND_OBJ(objResultPtr); NEXT_INST_F(1, 2, 1); } else { - if (Tcl_ListObjAppendList(interp, valuePtr, value2Ptr) != TCL_OK){ + if (Tcl_ListObjAppendList(interp, valuePtr, value2Ptr) != TCL_OK) { TRACE_ERROR(interp); goto gotError; } - TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr))); - NEXT_INST_F(1, 1, 0); + TRACE_APPEND_OBJ(valuePtr); + NEXT_INST_F0(1, 1); } - case INST_LREPLACE4: { - size_t numToDelete, numNewElems; - int end_indicator; - int haveSecondIndex, flags; - Tcl_Obj *fromIdxObj, *toIdxObj; - opnd = TclGetInt4AtPtr(pc + 1); - flags = TclGetInt1AtPtr(pc + 5); + case INST_LREPLACE: { + numArgs = TclGetUInt4AtPtr(pc + 1); + int flags = TclGetInt1AtPtr(pc + 5); /* Stack: ... listobj index1 ?index2? new1 ... newN */ - valuePtr = OBJ_AT_DEPTH(opnd-1); + valuePtr = OBJ_AT_DEPTH(numArgs - 1); /* haveSecondIndex==0 => pure insert */ - haveSecondIndex = (flags & TCL_LREPLACE4_SINGLE_INDEX) == 0; - numNewElems = opnd - 2 - haveSecondIndex; + int haveSecondIndex = (flags & TCL_LREPLACE_SINGLE_INDEX) == 0; + size_t numNewElems = numArgs - 2 - haveSecondIndex; /* end_indicator==1 => "end" is last element's index, 0=>index beyond */ - end_indicator = (flags & TCL_LREPLACE4_END_IS_LAST) != 0; - fromIdxObj = OBJ_AT_DEPTH(opnd - 2); - toIdxObj = haveSecondIndex ? OBJ_AT_DEPTH(opnd - 3) : NULL; + int endIndicator = (flags & TCL_LREPLACE_END_IS_LAST) != 0; + Tcl_Obj *fromIdxObj = OBJ_AT_DEPTH(numArgs - 2); + Tcl_Obj *toIdxObj = haveSecondIndex ? OBJ_AT_DEPTH(numArgs - 3) : NULL; if (Tcl_ListObjLength(interp, valuePtr, &length) != TCL_OK) { TRACE_ERROR(interp); goto gotError; } DECACHE_STACK_INFO(); - - if (TclGetIntForIndexM(interp, fromIdxObj, length - end_indicator, + if (TclGetIntForIndexM(interp, fromIdxObj, length - endIndicator, &fromIdx) != TCL_OK) { CACHE_STACK_INFO(); TRACE_ERROR(interp); goto gotError; } + if (flags & TCL_LREPLACE_NEED_IN_RANGE) { + if (fromIdx < 0 || fromIdx >= length) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "index \"%s\" out of range", Tcl_GetString(fromIdxObj))); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", "OUTOFRANGE", + (char *)NULL); + CACHE_STACK_INFO(); + TRACE_ERROR(interp); + goto gotError; + } + } if (fromIdx == TCL_INDEX_NONE) { fromIdx = 0; } else if (fromIdx > length) { fromIdx = length; } - numToDelete = 0; + size_t numToDelete = 0; if (toIdxObj) { - if (TclGetIntForIndexM(interp, toIdxObj, length - end_indicator, + if (TclGetIntForIndexM(interp, toIdxObj, length - endIndicator, &toIdx) != TCL_OK) { CACHE_STACK_INFO(); TRACE_ERROR(interp); @@ -5205,18 +5572,38 @@ TEBCresume( Tcl_DecrRefCount(objResultPtr); goto gotError; } - TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); - NEXT_INST_V(6, opnd, 1); + TRACE_APPEND_OBJ(objResultPtr); + NEXT_INST_V(6, numArgs, 1); } else { if (Tcl_ListObjReplace(interp, valuePtr, fromIdx, numToDelete, numNewElems, &OBJ_AT_DEPTH(numNewElems - 1)) != TCL_OK) { TRACE_ERROR(interp); goto gotError; } - TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr))); - NEXT_INST_V(6, opnd - 1, 0); + TRACE_APPEND_OBJ(valuePtr); + NEXT_INST_V(6, numArgs - 1, 0); } + } + + case INST_ARITH_SERIES: { + unsigned mask = TclGetUInt1AtPtr(pc + 1); + Tcl_Obj *count = (mask & TCL_ARITHSERIES_COUNT) ? OBJ_AT_DEPTH(0) : NULL; + Tcl_Obj *step = (mask & TCL_ARITHSERIES_STEP) ? OBJ_AT_DEPTH(1) : NULL; + Tcl_Obj *to = (mask & TCL_ARITHSERIES_TO) ? OBJ_AT_DEPTH(2) : NULL; + Tcl_Obj *from = (mask & TCL_ARITHSERIES_FROM) ? OBJ_AT_DEPTH(3) : NULL; + TRACE(("0x%x \"%s\" \"%s\" \"%s\" \"%s\" => ", + mask, O2S(from), O2S(to), O2S(step), O2S(count))); + DECACHE_STACK_INFO(); + // Decode arguments and construct the series. + objResultPtr = GenerateArithSeries(interp, from, to, step, count); + CACHE_STACK_INFO(); + if (objResultPtr == NULL) { + TRACE_ERROR(interp); + goto gotError; } + TRACE_APPEND_OBJ(objResultPtr); + NEXT_INST_V(2, 4, 1); + } /* * End of INST_LIST and related instructions. @@ -5287,78 +5674,59 @@ TEBCresume( valuePtr = OBJ_AT_TOS; slength = Tcl_GetCharLength(valuePtr); TclNewIntObj(objResultPtr, slength); - TRACE(("\"%.20s\" => %" TCL_Z_MODIFIER "u\n", O2S(valuePtr), slength)); + TRACE(("\"%.30s\" => %" SIZEu "\n", O2S(valuePtr), slength)); NEXT_INST_F(1, 1, 1); + { + Tcl_Size (*transform)(char *); + case INST_STR_UPPER: - valuePtr = OBJ_AT_TOS; - TRACE(("\"%.20s\" => ", O2S(valuePtr))); - if (Tcl_IsShared(valuePtr)) { - s1 = TclGetStringFromObj(valuePtr, &slength); - TclNewStringObj(objResultPtr, s1, slength); - slength = Tcl_UtfToUpper(TclGetString(objResultPtr)); - Tcl_SetObjLength(objResultPtr, slength); - TRACE_APPEND(("\"%.20s\"\n", O2S(objResultPtr))); - NEXT_INST_F(1, 1, 1); - } else { - slength = Tcl_UtfToUpper(TclGetString(valuePtr)); - Tcl_SetObjLength(valuePtr, slength); - TclFreeInternalRep(valuePtr); - TRACE_APPEND(("\"%.20s\"\n", O2S(valuePtr))); - NEXT_INST_F(1, 0, 0); - } + transform = Tcl_UtfToUpper; + goto applyStringTransform; case INST_STR_LOWER: - valuePtr = OBJ_AT_TOS; - TRACE(("\"%.20s\" => ", O2S(valuePtr))); - if (Tcl_IsShared(valuePtr)) { - s1 = TclGetStringFromObj(valuePtr, &slength); - TclNewStringObj(objResultPtr, s1, slength); - slength = Tcl_UtfToLower(TclGetString(objResultPtr)); - Tcl_SetObjLength(objResultPtr, slength); - TRACE_APPEND(("\"%.20s\"\n", O2S(objResultPtr))); - NEXT_INST_F(1, 1, 1); - } else { - slength = Tcl_UtfToLower(TclGetString(valuePtr)); - Tcl_SetObjLength(valuePtr, slength); - TclFreeInternalRep(valuePtr); - TRACE_APPEND(("\"%.20s\"\n", O2S(valuePtr))); - NEXT_INST_F(1, 0, 0); - } + transform = Tcl_UtfToLower; + goto applyStringTransform; case INST_STR_TITLE: + transform = Tcl_UtfToTitle; + applyStringTransform: valuePtr = OBJ_AT_TOS; - TRACE(("\"%.20s\" => ", O2S(valuePtr))); + TRACE(("\"%.30s\" => ", O2S(valuePtr))); if (Tcl_IsShared(valuePtr)) { + // Make copy of UTF-8 representation ONLY; we're about to modify it s1 = TclGetStringFromObj(valuePtr, &slength); TclNewStringObj(objResultPtr, s1, slength); - slength = Tcl_UtfToTitle(TclGetString(objResultPtr)); + slength = transform(TclGetString(objResultPtr)); Tcl_SetObjLength(objResultPtr, slength); - TRACE_APPEND(("\"%.20s\"\n", O2S(objResultPtr))); + TRACE_APPEND_OBJ(objResultPtr); NEXT_INST_F(1, 1, 1); } else { - slength = Tcl_UtfToTitle(TclGetString(valuePtr)); + slength = transform(TclGetString(valuePtr)); Tcl_SetObjLength(valuePtr, slength); TclFreeInternalRep(valuePtr); - TRACE_APPEND(("\"%.20s\"\n", O2S(valuePtr))); - NEXT_INST_F(1, 0, 0); + TRACE_APPEND_OBJ(valuePtr); + NEXT_INST_F0(1, 0); } + } case INST_STR_INDEX: value2Ptr = OBJ_AT_TOS; valuePtr = OBJ_UNDER_TOS; - TRACE(("\"%.20s\" %.20s => ", O2S(valuePtr), O2S(value2Ptr))); + TRACE(("\"%.30s\" %.20s => ", O2S(valuePtr), O2S(value2Ptr))); /* * Get char length to calculate what 'end' means. */ slength = Tcl_GetCharLength(valuePtr); - DECACHE_STACK_INFO(); - if (TclGetIntForIndexM(interp, value2Ptr, slength-1, &index)!=TCL_OK) { + { + DECACHE_STACK_INFO(); + int code = TclGetIntForIndexM(interp, value2Ptr, slength - 1, &index); CACHE_STACK_INFO(); - TRACE_ERROR(interp); - goto gotError; + if (code != TCL_OK) { + TRACE_ERROR(interp); + goto gotError; + } } - CACHE_STACK_INFO(); if (index < 0 || index >= slength) { TclNewObj(objResultPtr); @@ -5367,7 +5735,7 @@ TEBCresume( Tcl_GetBytesFromObj(NULL, valuePtr, (Tcl_Size *)NULL)+index, 1); } else if (valuePtr->bytes && slength == valuePtr->length) { objResultPtr = Tcl_NewStringObj((const char *) - valuePtr->bytes+index, 1); + valuePtr->bytes + index, 1); } else { char buf[4] = ""; int ch = Tcl_GetUniChar(valuePtr, index); @@ -5385,7 +5753,7 @@ TEBCresume( } } - TRACE_APPEND(("\"%s\"\n", O2S(objResultPtr))); + TRACE_APPEND_OBJ(objResultPtr); NEXT_INST_F(1, 2, 1); case INST_STR_RANGE: @@ -5394,12 +5762,8 @@ TEBCresume( slength = Tcl_GetCharLength(OBJ_AT_DEPTH(2)) - 1; DECACHE_STACK_INFO(); - if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, slength, &fromIdx) != TCL_OK) { - CACHE_STACK_INFO(); - TRACE_ERROR(interp); - goto gotError; - } - if (TclGetIntForIndexM(interp, OBJ_AT_TOS, slength, &toIdx) != TCL_OK) { + if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, slength, &fromIdx) != TCL_OK || + TclGetIntForIndexM(interp, OBJ_AT_TOS, slength, &toIdx) != TCL_OK) { CACHE_STACK_INFO(); TRACE_ERROR(interp); goto gotError; @@ -5411,32 +5775,32 @@ TEBCresume( } else { objResultPtr = Tcl_GetRange(OBJ_AT_DEPTH(2), fromIdx, toIdx); } - TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); + TRACE_APPEND_OBJ(objResultPtr); NEXT_INST_V(1, 3, 1); case INST_STR_RANGE_IMM: valuePtr = OBJ_AT_TOS; - fromIdx = TclGetInt4AtPtr(pc+1); - toIdx = TclGetInt4AtPtr(pc+5); + fromIdxEnc = TclGetInt4AtPtr(pc + 1); + toIdxEnc = TclGetInt4AtPtr(pc + 5); slength = Tcl_GetCharLength(valuePtr); - TRACE(("\"%.20s\" %d %d => ", O2S(valuePtr), (int)(fromIdx), (int)(toIdx))); + TRACE(("\"%.20s\" %d %d => ", O2S(valuePtr), fromIdxEnc, toIdxEnc)); /* Every range of an empty value is an empty value */ if (slength == 0) { TRACE_APPEND(("\n")); - NEXT_INST_F(9, 0, 0); + NEXT_INST_F0(9, 0); } /* Decode index operands. */ - toIdx = TclIndexDecode(toIdx, slength - 1); - fromIdx = TclIndexDecode(fromIdx, slength - 1); + toIdx = TclIndexDecode(toIdxEnc, slength - 1); + fromIdx = TclIndexDecode(fromIdxEnc, slength - 1); if (toIdx == TCL_INDEX_NONE) { TclNewObj(objResultPtr); } else { objResultPtr = Tcl_GetRange(valuePtr, fromIdx, toIdx); } - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + TRACE_APPEND_OBJ(objResultPtr); NEXT_INST_F(9, 1, 1); { @@ -5465,9 +5829,9 @@ TEBCresume( (void) POP_OBJECT(); if ((toIdx < 0) || (fromIdx > slength) || (toIdx < fromIdx)) { - TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr))); + TRACE_APPEND_OBJ(valuePtr); TclDecrRefCount(value3Ptr); - NEXT_INST_F(1, 0, 0); + NEXT_INST_F0(1, 0); } if (fromIdx < 0) { @@ -5481,8 +5845,8 @@ TEBCresume( if ((fromIdx == 0) && (toIdx == slength)) { TclDecrRefCount(OBJ_AT_TOS); OBJ_AT_TOS = value3Ptr; - TRACE_APPEND(("\"%.30s\"\n", O2S(value3Ptr))); - NEXT_INST_F(1, 0, 0); + TRACE_APPEND_OBJ(value3Ptr); + NEXT_INST_F0(1, 0); } objResultPtr = TclStringReplace(interp, valuePtr, fromIdx, @@ -5492,11 +5856,11 @@ TEBCresume( /* See [Bug 82e7f67325] */ TclDecrRefCount(OBJ_AT_TOS); OBJ_AT_TOS = value3Ptr; - TRACE_APPEND(("\"%.30s\"\n", O2S(value3Ptr))); - NEXT_INST_F(1, 0, 0); + TRACE_APPEND_OBJ(value3Ptr); + NEXT_INST_F0(1, 0); } TclDecrRefCount(value3Ptr); - TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); + TRACE_APPEND_OBJ(objResultPtr); NEXT_INST_F(1, 1, 1); case INST_STR_MAP: @@ -5576,18 +5940,17 @@ TEBCresume( NEXT_INST_F(1, 2, 1); case INST_STR_CLASS: - opnd = TclGetInt1AtPtr(pc+1); + tblIdx = TclGetUInt1AtPtr(pc + 1); valuePtr = OBJ_AT_TOS; - TRACE(("%s \"%.30s\" => ", tclStringClassTable[opnd].name, + TRACE(("%s \"%.30s\" => ", tclStringClassTable[tblIdx].name, O2S(valuePtr))); ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &slength); match = 1; if (slength > 0) { - int ch; end = ustring1 + slength; for (p=ustring1 ; p<end ; ) { - ch = *p++; - if (!tclStringClassTable[opnd].comparator(ch)) { + int ch = *p++; + if (!tclStringClassTable[tblIdx].comparator(ch)) { match = 0; break; } @@ -5598,7 +5961,7 @@ TEBCresume( } case INST_STR_MATCH: - nocase = TclGetInt1AtPtr(pc+1); + nocase = TclGetInt1AtPtr(pc + 1); valuePtr = OBJ_AT_TOS; /* String */ value2Ptr = OBJ_UNDER_TOS; /* Pattern */ @@ -5609,18 +5972,14 @@ TEBCresume( if (TclHasInternalRep(valuePtr, &tclStringType) || TclHasInternalRep(value2Ptr, &tclStringType)) { - Tcl_UniChar *ustring1, *ustring2; - - ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &slength); - ustring2 = Tcl_GetUnicodeFromObj(value2Ptr, &length2); + Tcl_UniChar *ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &slength); + Tcl_UniChar *ustring2 = Tcl_GetUnicodeFromObj(value2Ptr, &length2); match = TclUniCharMatch(ustring1, slength, ustring2, length2, nocase); } else if (TclIsPureByteArray(valuePtr) && TclIsPureByteArray(value2Ptr) && !nocase) { - unsigned char *bytes1, *bytes2; Tcl_Size wlen1 = 0, wlen2 = 0; - - bytes1 = Tcl_GetBytesFromObj(NULL, valuePtr, &wlen1); - bytes2 = Tcl_GetBytesFromObj(NULL, value2Ptr, &wlen2); + unsigned char *bytes1 = Tcl_GetBytesFromObj(NULL, valuePtr, &wlen1); + unsigned char *bytes2 = Tcl_GetBytesFromObj(NULL, value2Ptr, &wlen2); match = TclByteArrayMatch(bytes1, wlen1, bytes2, wlen2, 0); } else { match = Tcl_StringCaseMatch(TclGetString(valuePtr), @@ -5686,7 +6045,7 @@ TEBCresume( printf("\n"); } #endif - NEXT_INST_F(1, 1, 0); + NEXT_INST_F0(1, 1); } else { objResultPtr = Tcl_NewStringObj(string1+trim1, slength-trim1-trim2); #ifdef TCL_COMPILE_DEBUG @@ -5699,8 +6058,8 @@ TEBCresume( } } - case INST_REGEXP: - cflags = TclGetInt1AtPtr(pc+1); /* RE compile flages like NOCASE */ + case INST_REGEXP: { + int cflags = TclGetInt1AtPtr(pc+1); // RE compile flags like NOCASE valuePtr = OBJ_AT_TOS; /* String */ value2Ptr = OBJ_UNDER_TOS; /* Pattern */ TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr))); @@ -5709,30 +6068,34 @@ TEBCresume( * Compile and match the regular expression. */ - { - Tcl_RegExp regExpr = - Tcl_GetRegExpFromObj(interp, value2Ptr, cflags); - - if (regExpr == NULL) { - TRACE_ERROR(interp); - goto gotError; - } - match = Tcl_RegExpExecObj(interp, regExpr, valuePtr, 0, 0, 0); - if (match < 0) { - TRACE_ERROR(interp); - goto gotError; - } + DECACHE_STACK_INFO(); + Tcl_RegExp regExpr = Tcl_GetRegExpFromObj(interp, value2Ptr, cflags); + if (regExpr == NULL) { + CACHE_STACK_INFO(); + TRACE_ERROR(interp); + goto gotError; + } + match = Tcl_RegExpExecObj(interp, regExpr, valuePtr, 0, 0, 0); + CACHE_STACK_INFO(); + if (match < 0) { + TRACE_ERROR(interp); + goto gotError; } - - TRACE_APPEND(("%d\n", match)); /* * Peep-hole optimisation: if you're about to jump, do jump from here. * Adjustment is 2 due to the nocase byte. */ + TRACE_APPEND(("%d\n", match)); JUMP_PEEPHOLE_F(match, 2, 2); } + } + case INST_IS_EMPTY: { + int empty = Tcl_IsEmpty(OBJ_AT_TOS); + TRACE(("\"%.30s\" => %d", O2S(OBJ_AT_TOS), empty)); + JUMP_PEEPHOLE_F(empty, 1, 1); + } /* * End of string-related instructions. @@ -5916,7 +6279,6 @@ TEBCresume( (Tcl_WideUInt)w2*(Tcl_WideUInt)wResult); goto wideResultOfArithmetic; } - break; case INST_RSHIFT: if (w2 < 0) { @@ -5965,7 +6327,6 @@ TEBCresume( wResult = w1 >> ((int) w2); goto wideResultOfArithmetic; } - break; case INST_LSHIFT: if (w2 < 0) { @@ -6051,10 +6412,10 @@ TEBCresume( TRACE_ERROR(interp); goto gotError; } else if (objResultPtr == NULL) { - TRACE_APPEND(("%s\n", O2S(valuePtr))); - NEXT_INST_F(1, 1, 0); + TRACE_APPEND_NUM_OBJ(valuePtr); + NEXT_INST_F0(1, 1); } else { - TRACE_APPEND(("%s\n", O2S(objResultPtr))); + TRACE_APPEND_NUM_OBJ(objResultPtr); NEXT_INST_F(1, 2, 1); } @@ -6083,7 +6444,7 @@ TEBCresume( * NaN first argument -> result is also NaN. */ - NEXT_INST_F(1, 1, 0); + NEXT_INST_F0(1, 1); } #endif @@ -6154,8 +6515,7 @@ TEBCresume( } TclSetIntObj(valuePtr, wResult); TRACE(("%s\n", O2S(valuePtr))); - NEXT_INST_F(1, 1, 0); - break; + NEXT_INST_F0(1, 1); case INST_DIV: if (w2 == 0) { @@ -6217,20 +6577,19 @@ TEBCresume( TRACE_APPEND(("OUT OF MEMORY\n")); goto outOfMemory; } else if (objResultPtr == NULL) { - TRACE_APPEND(("%s\n", O2S(valuePtr))); - NEXT_INST_F(1, 1, 0); + TRACE_APPEND_NUM_OBJ(valuePtr); + NEXT_INST_F0(1, 1); } else { - TRACE_APPEND(("%s\n", O2S(objResultPtr))); + TRACE_APPEND_NUM_OBJ(objResultPtr); NEXT_INST_F(1, 2, 1); } case INST_LNOT: { - int b; - valuePtr = OBJ_AT_TOS; /* TODO - check claim that taking address of b harms performance */ /* TODO - consider optimization search for constants */ + int b; if (TclGetBooleanFromObj(NULL, valuePtr, &b) != TCL_OK) { TRACE(("\"%.20s\" => ERROR: illegal type %s\n", O2S(valuePtr), (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); @@ -6265,20 +6624,20 @@ TEBCresume( w1 = *((const Tcl_WideInt *) ptr1); if (Tcl_IsShared(valuePtr)) { TclNewIntObj(objResultPtr, ~w1); - TRACE_APPEND(("%s\n", O2S(objResultPtr))); + TRACE_APPEND_NUM_OBJ(objResultPtr); NEXT_INST_F(1, 1, 1); } TclSetIntObj(valuePtr, ~w1); TRACE_APPEND(("%s\n", O2S(valuePtr))); - NEXT_INST_F(1, 0, 0); + NEXT_INST_F0(1, 0); } objResultPtr = ExecuteExtendedUnaryMathOp(*pc, valuePtr); if (objResultPtr != NULL) { - TRACE_APPEND(("%s\n", O2S(objResultPtr))); + TRACE_APPEND_NUM_OBJ(objResultPtr); NEXT_INST_F(1, 1, 1); } else { - TRACE_APPEND(("%s\n", O2S(valuePtr))); - NEXT_INST_F(1, 0, 0); + TRACE_APPEND_NUM_OBJ(valuePtr); + NEXT_INST_F0(1, 0); } case INST_UMINUS: @@ -6286,7 +6645,7 @@ TEBCresume( TRACE(("\"%.20s\" => ", O2S(valuePtr))); if ((GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) || IsErroringNaNType(type1)) { - TRACE_APPEND(("ERROR: illegal type %s \n", + TRACE_APPEND(("ERROR: illegal type %s\n", (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); DECACHE_STACK_INFO(); IllegalExprOperandType(interp, "", pc, valuePtr); @@ -6296,30 +6655,31 @@ TEBCresume( switch (type1) { case TCL_NUMBER_NAN: /* -NaN => NaN */ - TRACE_APPEND(("%s\n", O2S(valuePtr))); - NEXT_INST_F(1, 0, 0); - break; + TRACE_APPEND_NUM_OBJ(valuePtr); + NEXT_INST_F0(1, 0); case TCL_NUMBER_INT: w1 = *((const Tcl_WideInt *) ptr1); if (w1 != WIDE_MIN) { if (Tcl_IsShared(valuePtr)) { TclNewIntObj(objResultPtr, -w1); - TRACE_APPEND(("%s\n", O2S(objResultPtr))); + TRACE_APPEND_NUM_OBJ(objResultPtr); NEXT_INST_F(1, 1, 1); } TclSetIntObj(valuePtr, -w1); - TRACE_APPEND(("%s\n", O2S(valuePtr))); - NEXT_INST_F(1, 0, 0); + TRACE_APPEND_NUM_OBJ(valuePtr); + NEXT_INST_F0(1, 0); } - /* FALLTHROUGH */ + TCL_FALLTHROUGH(); + default: + break; } objResultPtr = ExecuteExtendedUnaryMathOp(*pc, valuePtr); if (objResultPtr != NULL) { - TRACE_APPEND(("%s\n", O2S(objResultPtr))); + TRACE_APPEND_NUM_OBJ(objResultPtr); NEXT_INST_F(1, 1, 1); } else { - TRACE_APPEND(("%s\n", O2S(valuePtr))); - NEXT_INST_F(1, 0, 0); + TRACE_APPEND_NUM_OBJ(valuePtr); + NEXT_INST_F0(1, 0); } case INST_UPLUS: @@ -6349,7 +6709,7 @@ TEBCresume( /* ... TryConvertToNumeric($NonNumeric) is acceptable */ TRACE_APPEND(("not numeric\n")); - NEXT_INST_F(1, 0, 0); + NEXT_INST_F0(1, 0); } if (IsErroringNaNType(type1)) { if (*pc == INST_UPLUS) { @@ -6386,7 +6746,7 @@ TEBCresume( if (valuePtr->bytes == NULL) { TRACE_APPEND(("numeric, same Tcl_Obj\n")); - NEXT_INST_F(1, 0, 0); + NEXT_INST_F0(1, 0); } if (Tcl_IsShared(valuePtr)) { /* @@ -6405,9 +6765,8 @@ TEBCresume( } TclInvalidateStringRep(valuePtr); TRACE_APPEND(("numeric, same Tcl_Obj\n")); - NEXT_INST_F(1, 0, 0); + NEXT_INST_F0(1, 0); } - break; /* * End of numeric operator instructions. @@ -6424,7 +6783,6 @@ TEBCresume( } TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(valuePtr)), objResultPtr); NEXT_INST_F(1, 0, 1); - break; case INST_BREAK: /* @@ -6462,17 +6820,17 @@ TEBCresume( * corresponding Tcl_Objs to the stack. */ - opnd = TclGetUInt4AtPtr(pc+1); - infoPtr = (ForeachInfo *)codePtr->auxDataArrayPtr[opnd].clientData; + tblIdx = TclGetUInt4AtPtr(pc + 1); + infoPtr = (ForeachInfo *)codePtr->auxDataArrayPtr[tblIdx].clientData; numLists = infoPtr->numLists; - TRACE(("%u => ", opnd)); + TRACE(("%u => ", tblIdx)); /* * Compute the number of iterations that will be run: iterMax */ iterMax = 0; - listTmpDepth = numLists-1; + listTmpDepth = numLists - 1; for (i = 0; i < numLists; i++) { varListPtr = infoPtr->varLists[i]; numVars = varListPtr->numVars; @@ -6480,7 +6838,7 @@ TEBCresume( DECACHE_STACK_INFO(); if (TclListObjLength(interp, listPtr, &listLen) != TCL_OK) { CACHE_STACK_INFO(); - TRACE_APPEND(("ERROR converting list %" TCL_Z_MODIFIER "d, \"%s\": %s", + TRACE_APPEND(("ERROR converting list %" SIZEd ", \"%.30s\": %s\n", i, O2S(listPtr), O2S(Tcl_GetObjResult(interp)))); goto gotError; } @@ -6525,6 +6883,7 @@ TEBCresume( */ pc += 5 - infoPtr->loopCtTemp; + TCL_FALLTHROUGH(); case INST_FOREACH_STEP: /* TODO: address abstract list indexing here! */ /* @@ -6587,7 +6946,7 @@ TEBCresume( valuePtr = elements[valIndex]; } else { status = Tcl_ListObjIndex( - interp, listPtr, valIndex, &valuePtr); + interp, listPtr, valIndex, &valuePtr); if (status != TCL_OK) { /* Could happen for abstract lists */ CACHE_STACK_INFO(); @@ -6618,9 +6977,9 @@ TEBCresume( } else { DECACHE_STACK_INFO(); if (TclPtrSetVarIdx(interp, varPtr, NULL, NULL, NULL, - valuePtr, TCL_LEAVE_ERR_MSG, varIndex)==NULL){ + valuePtr, TCL_LEAVE_ERR_MSG, varIndex) == NULL) { CACHE_STACK_INFO(); - TRACE_APPEND(("ERROR init. index temp %" TCL_SIZE_MODIFIER "d: %.30s", + TRACE_APPEND(("ERROR init. index temp %" SIZEd ": %s\n", varIndex, O2S(Tcl_GetObjResult(interp)))); goto gotError; } @@ -6632,26 +6991,23 @@ TEBCresume( } TRACE_APPEND(("jump to loop start\n")); /* loopCtTemp being 'misused' for storing the jump size */ - NEXT_INST_F(infoPtr->loopCtTemp, 0, 0); + NEXT_INST_F0(infoPtr->loopCtTemp, 0); } TRACE_APPEND(("loop has no more iterations\n")); #ifdef TCL_COMPILE_DEBUG - NEXT_INST_F(1, 0, 0); + NEXT_INST_F0(1, 0); #else - /* - * FALL THROUGH - */ pc++; + TCL_FALLTHROUGH(); #endif - case INST_FOREACH_END: /* THIS INSTRUCTION IS ONLY CALLED AS A BREAK TARGET */ tmpPtr = OBJ_AT_TOS; infoPtr = (ForeachInfo *)tmpPtr->internalRep.twoPtrValue.ptr1; numLists = infoPtr->numLists; TRACE(("=> loop terminated\n")); - NEXT_INST_V(1, numLists+2, 0); + NEXT_INST_V(1, numLists + 2, 0); case INST_LMAP_COLLECT: /* @@ -6667,15 +7023,14 @@ TEBCresume( tmpPtr = OBJ_AT_DEPTH(1); infoPtr = (ForeachInfo *)tmpPtr->internalRep.twoPtrValue.ptr1; numLists = infoPtr->numLists; - TRACE_APPEND(("=> appending to list at depth %" TCL_SIZE_MODIFIER "d\n", 3 + numLists)); + TRACE_APPEND(("=> appending to list at depth %" SIZEd "\n", 3 + numLists)); objPtr = OBJ_AT_DEPTH(3 + numLists); Tcl_ListObjAppendElement(NULL, objPtr, OBJ_AT_TOS); - NEXT_INST_F(1, 1, 0); + NEXT_INST_F0(1, 1); } - break; - case INST_BEGIN_CATCH4: + case INST_BEGIN_CATCH: /* * Record start of the catch command with exception range index equal * to the operand. Push the current stack depth onto the special catch @@ -6683,11 +7038,10 @@ TEBCresume( */ *(++catchTop) = (Tcl_Obj *)INT2PTR(CURR_DEPTH); - TRACE(("%u => catchTop=%" TCL_T_MODIFIER "d, stackTop=%" TCL_SIZE_MODIFIER "d\n", - TclGetUInt4AtPtr(pc+1), (catchTop - initCatchTop - 1), + TRACE(("%u => catchTop=%" SIZEd ", stackTop=%" SIZEd "\n", + TclGetUInt4AtPtr(pc + 1), (Tcl_Size)(catchTop - initCatchTop - 1), CURR_DEPTH)); - NEXT_INST_F(5, 0, 0); - break; + NEXT_INST_F0(5, 0); case INST_END_CATCH: catchTop--; @@ -6695,9 +7049,8 @@ TEBCresume( Tcl_ResetResult(interp); CACHE_STACK_INFO(); result = TCL_OK; - TRACE(("=> catchTop=%" TCL_Z_MODIFIER "u\n", (size_t)(catchTop - initCatchTop - 1))); - NEXT_INST_F(1, 0, 0); - break; + TRACE(("=> catchTop=%" SIZEd "\n", (Tcl_Size)(catchTop - initCatchTop - 1))); + NEXT_INST_F0(1, 0); case INST_PUSH_RESULT: objResultPtr = Tcl_GetObjResult(interp); @@ -6711,13 +7064,11 @@ TEBCresume( Tcl_IncrRefCount(objPtr); iPtr->objResultPtr = objPtr; NEXT_INST_F(1, 0, -1); - break; case INST_PUSH_RETURN_CODE: TclNewIntObj(objResultPtr, result); TRACE(("=> %u\n", result)); NEXT_INST_F(1, 0, 1); - break; case INST_PUSH_RETURN_OPTIONS: DECACHE_STACK_INFO(); @@ -6725,11 +7076,12 @@ TEBCresume( CACHE_STACK_INFO(); TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(1, 0, 1); - break; +#ifndef REMOVE_DEPRECATED_OPCODES case INST_RETURN_CODE_BRANCH: { int code; + DEPRECATED_OPCODE_MARK(INST_RETURN_CODE_BRANCH); if (TclGetIntFromObj(NULL, OBJ_AT_TOS, &code) != TCL_OK) { Tcl_Panic("INST_RETURN_CODE_BRANCH: TOS not a return code!"); } @@ -6739,8 +7091,51 @@ TEBCresume( if (code < TCL_ERROR || code > TCL_CONTINUE) { code = TCL_CONTINUE + 1; } - TRACE(("\"%s\" => jump offset %d\n", O2S(OBJ_AT_TOS), 2*code-1)); - NEXT_INST_F(2*code-1, 1, 0); + TRACE(("\"%s\" => jump offset %d\n", O2S(OBJ_AT_TOS), 2*code - 1)); + NEXT_INST_F0(2*code - 1, 1); + } +#endif + + case INST_ERROR_PREFIX_EQ: { + /* + * A special equality operator for errorcode prefix matching in + * try/trap. Skips checking for abstract lists and takes no care about + * whether one list is a sublist of the other; that's never the case as + * the [try] compiler deduplicates. That lets us get the elements of + * each list just once. + */ + + int match, index; + Tcl_Obj **aObjv, **bObjv; + Tcl_Size aObjc, bObjc, cmpLen; + + cmpLen = TclGetUInt4AtPtr(pc + 1); + value2Ptr = OBJ_AT_TOS; + valuePtr = OBJ_UNDER_TOS; + TRACE(("\"%.20s\" \"%.20s\" %u => ", + O2S(valuePtr), O2S(value2Ptr), (unsigned) cmpLen)); + if (TclListObjGetElements(interp, valuePtr, &aObjc, &aObjv) != TCL_OK) { + TRACE_ERROR(interp); + goto gotError; + } + if (TclListObjGetElements(interp, value2Ptr, &bObjc, &bObjv) != TCL_OK) { + TRACE_ERROR(interp); + goto gotError; + } + + for (match = 1, index = 0; index < cmpLen && match; index++) { + Tcl_Obj *a = ((Tcl_Size) index < aObjc) ? aObjv[index] : NULL; + Tcl_Obj *b = ((Tcl_Size) index < bObjc) ? bObjv[index] : NULL; + if (a && b) { + match = TclStringCmp(a, b, 1, 0, -1) == 0; + } else if (a) { + match = TclGetString(a)[0] == '\0'; + } else if (b) { + match = TclGetString(b)[0] == '\0'; + } + } + TRACE_APPEND(("%d\n", match ? 1 : 0)); + JUMP_PEEPHOLE_F(match ? 1 : 0, 5, 2); } /* @@ -6749,7 +7144,7 @@ TEBCresume( */ { - int opnd2, allocateDict, done, allocdict; + int allocateDict, done, allocdict; Tcl_Size i; Tcl_Obj *dictPtr, *statePtr, *keyPtr, *listPtr, *varNamePtr, *keysPtr; Tcl_Obj *emptyPtr, **keyPtrPtr; @@ -6766,19 +7161,18 @@ TEBCresume( goto gotError; } TRACE_APPEND(("OK\n")); - NEXT_INST_F(1, 1, 0); + NEXT_INST_F0(1, 1); } - break; case INST_DICT_EXISTS: { int found; - opnd = TclGetUInt4AtPtr(pc+1); - TRACE(("%u => ", opnd)); - dictPtr = OBJ_AT_DEPTH(opnd); - if (opnd > 1) { - dictPtr = TclTraceDictPath(NULL, dictPtr, opnd-1, - &OBJ_AT_DEPTH(opnd-1), DICT_PATH_EXISTS); + numArgs = TclGetUInt4AtPtr(pc + 1); + TRACE(("%u => ", (unsigned)numArgs)); + dictPtr = OBJ_AT_DEPTH(numArgs); + if (numArgs > 1) { + dictPtr = TclTraceDictPath(NULL, dictPtr, numArgs-1, + &OBJ_AT_DEPTH(numArgs-1), DICT_PATH_EXISTS); if (dictPtr == NULL || dictPtr == DICT_PATH_NON_EXISTENT) { found = 0; goto afterDictExists; @@ -6800,27 +7194,67 @@ TEBCresume( * someone doing something else). */ - JUMP_PEEPHOLE_V(found, 5, opnd+1); + JUMP_PEEPHOLE_V(found, 5, numArgs + 1); } + case INST_DICT_PUT: + dictPtr = OBJ_AT_DEPTH(2); + TRACE(("\"%.30s\" \"%.30s\" \"%.30s\" => ", + O2S(dictPtr), O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS))); + allocateDict = Tcl_IsShared(dictPtr); + if (allocateDict) { + dictPtr = Tcl_DuplicateObj(dictPtr); + } + if (Tcl_DictObjPut(interp, dictPtr, OBJ_UNDER_TOS, OBJ_AT_TOS) != TCL_OK) { + Tcl_BounceRefCount(dictPtr); + TRACE_ERROR(interp); + goto gotError; + } + TRACE_APPEND_OBJ(dictPtr); + if (allocateDict) { + objResultPtr = dictPtr; + NEXT_INST_V(1, 3, 1); + } else { + NEXT_INST_F0(1, 2); + } + case INST_DICT_REMOVE: + dictPtr = OBJ_UNDER_TOS; + TRACE(("\"%.30s\" \"%.30s\" => ", + O2S(dictPtr), O2S(OBJ_AT_TOS))); + allocateDict = Tcl_IsShared(dictPtr); + if (allocateDict) { + dictPtr = Tcl_DuplicateObj(dictPtr); + } + if (Tcl_DictObjRemove(interp, dictPtr, OBJ_AT_TOS) != TCL_OK) { + Tcl_BounceRefCount(dictPtr); + TRACE_ERROR(interp); + goto gotError; + } + TRACE_APPEND_OBJ(dictPtr); + if (allocateDict) { + objResultPtr = dictPtr; + NEXT_INST_F(1, 2, 1); + } else { + NEXT_INST_F0(1, 1); + } case INST_DICT_GET: - opnd = TclGetUInt4AtPtr(pc+1); - TRACE(("%u => ", opnd)); - dictPtr = OBJ_AT_DEPTH(opnd); - if (opnd > 1) { - dictPtr = TclTraceDictPath(interp, dictPtr, opnd-1, - &OBJ_AT_DEPTH(opnd-1), DICT_PATH_READ); + numArgs = TclGetUInt4AtPtr(pc + 1); + TRACE(("%u => ", (unsigned)numArgs)); + dictPtr = OBJ_AT_DEPTH(numArgs); + if (numArgs > 1) { + dictPtr = TclTraceDictPath(interp, dictPtr, numArgs - 1, + &OBJ_AT_DEPTH(numArgs - 1), DICT_PATH_READ); if (dictPtr == NULL) { - TRACE_WITH_OBJ(( - "ERROR tracing dictionary path into \"%.30s\": ", - O2S(OBJ_AT_DEPTH(opnd))), - Tcl_GetObjResult(interp)); + TRACE_APPEND(( + "ERROR tracing dictionary path into \"%.30s\": %s\n", + O2S(OBJ_AT_DEPTH(numArgs)), + O2S(Tcl_GetObjResult(interp)))); goto gotError; } } if (Tcl_DictObjGet(interp, dictPtr, OBJ_AT_TOS, &objResultPtr) != TCL_OK) { - TRACE_APPEND(("ERROR reading leaf dictionary key \"%.30s\": %s", - O2S(dictPtr), O2S(Tcl_GetObjResult(interp)))); + TRACE_APPEND(("ERROR reading leaf dictionary key \"%.30s\": %s\n", + O2S(OBJ_AT_TOS), O2S(Tcl_GetObjResult(interp)))); goto gotError; } if (!objResultPtr) { @@ -6831,23 +7265,24 @@ TEBCresume( Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT", TclGetString(OBJ_AT_TOS), (char *)NULL); CACHE_STACK_INFO(); - TRACE_ERROR(interp); + TRACE_APPEND(("ERROR leaf dictionary key \"%.30s\" absent: %s\n", + O2S(OBJ_AT_TOS), O2S(Tcl_GetObjResult(interp)))); goto gotError; } - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_V(5, opnd+1, 1); + TRACE_APPEND_OBJ(objResultPtr); + NEXT_INST_V(5, numArgs + 1, 1); case INST_DICT_GET_DEF: - opnd = TclGetUInt4AtPtr(pc+1); - TRACE(("%u => ", opnd)); - dictPtr = OBJ_AT_DEPTH(opnd+1); - if (opnd > 1) { - dictPtr = TclTraceDictPath(interp, dictPtr, opnd-1, - &OBJ_AT_DEPTH(opnd), DICT_PATH_EXISTS); + numArgs = TclGetUInt4AtPtr(pc + 1); + TRACE(("%u => ", (unsigned)numArgs)); + dictPtr = OBJ_AT_DEPTH(numArgs+1); + if (numArgs > 1) { + dictPtr = TclTraceDictPath(interp, dictPtr, numArgs-1, + &OBJ_AT_DEPTH(numArgs), DICT_PATH_EXISTS); if (dictPtr == NULL) { - TRACE_WITH_OBJ(( - "ERROR tracing dictionary path into \"%.30s\": ", - O2S(OBJ_AT_DEPTH(opnd+1))), - Tcl_GetObjResult(interp)); + TRACE_APPEND(( + "ERROR tracing dictionary path into \"%.30s\": %s\n", + O2S(OBJ_AT_DEPTH(numArgs + 1)), + O2S(Tcl_GetObjResult(interp)))); goto gotError; } else if (dictPtr == DICT_PATH_NON_EXISTENT) { goto dictGetDefUseDefault; @@ -6855,33 +7290,33 @@ TEBCresume( } if (Tcl_DictObjGet(interp, dictPtr, OBJ_UNDER_TOS, &objResultPtr) != TCL_OK) { - TRACE_APPEND(("ERROR reading leaf dictionary key \"%.30s\": %s", + TRACE_APPEND(("ERROR reading leaf dictionary key \"%.30s\": %s\n", O2S(dictPtr), O2S(Tcl_GetObjResult(interp)))); goto gotError; } else if (!objResultPtr) { dictGetDefUseDefault: objResultPtr = OBJ_AT_TOS; } - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_V(5, opnd+2, 1); + TRACE_APPEND_OBJ(objResultPtr); + NEXT_INST_V(5, numArgs + 2, 1); case INST_DICT_SET: case INST_DICT_UNSET: case INST_DICT_INCR_IMM: - opnd = TclGetUInt4AtPtr(pc+1); - opnd2 = TclGetUInt4AtPtr(pc+5); + numArgs = TclGetUInt4AtPtr(pc + 1); + varIdx = TclGetUInt4AtPtr(pc + 5); - varPtr = LOCAL(opnd2); + varPtr = LOCAL(varIdx); while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } - TRACE(("%u %u => ", opnd, opnd2)); + TRACE(("%u %u => ", (unsigned)numArgs, (unsigned)varIdx)); if (TclIsVarDirectReadable(varPtr)) { dictPtr = varPtr->value.objPtr; } else { DECACHE_STACK_INFO(); dictPtr = TclPtrGetVarIdx(interp, varPtr, NULL, NULL, NULL, 0, - opnd2); + varIdx); CACHE_STACK_INFO(); } if (dictPtr == NULL) { @@ -6896,22 +7331,21 @@ TEBCresume( switch (*pc) { case INST_DICT_SET: - cleanup = opnd + 1; - result = Tcl_DictObjPutKeyList(interp, dictPtr, opnd, - &OBJ_AT_DEPTH(opnd), OBJ_AT_TOS); + cleanup = numArgs + 1; + result = Tcl_DictObjPutKeyList(interp, dictPtr, numArgs, + &OBJ_AT_DEPTH(numArgs), OBJ_AT_TOS); break; - case INST_DICT_INCR_IMM: + case INST_DICT_INCR_IMM: { + int increment = TclGetInt4AtPtr(pc + 1); cleanup = 1; - opnd = TclGetInt4AtPtr(pc+1); result = Tcl_DictObjGet(interp, dictPtr, OBJ_AT_TOS, &valuePtr); if (result != TCL_OK) { break; } if (valuePtr == NULL) { - Tcl_DictObjPut(NULL, dictPtr, OBJ_AT_TOS, Tcl_NewWideIntObj(opnd)); + Tcl_DictObjPut(NULL, dictPtr, OBJ_AT_TOS, Tcl_NewWideIntObj(increment)); } else { - TclNewIntObj(value2Ptr, opnd); - Tcl_IncrRefCount(value2Ptr); + TclNewIntObj(value2Ptr, increment); if (Tcl_IsShared(valuePtr)) { valuePtr = Tcl_DuplicateObj(valuePtr); Tcl_DictObjPut(NULL, dictPtr, OBJ_AT_TOS, valuePtr); @@ -6920,17 +7354,17 @@ TEBCresume( if (result == TCL_OK) { TclInvalidateStringRep(dictPtr); } - TclDecrRefCount(value2Ptr); + Tcl_BounceRefCount(value2Ptr); } break; + } case INST_DICT_UNSET: - cleanup = opnd; - result = Tcl_DictObjRemoveKeyList(interp, dictPtr, opnd, - &OBJ_AT_DEPTH(opnd-1)); + cleanup = numArgs; + result = Tcl_DictObjRemoveKeyList(interp, dictPtr, numArgs, + &OBJ_AT_DEPTH(numArgs - 1)); break; default: - cleanup = 0; /* stop compiler warning */ - Tcl_Panic("Should not happen!"); + TCL_UNREACHABLE(); } if (result != TCL_OK) { @@ -6956,7 +7390,7 @@ TEBCresume( Tcl_IncrRefCount(dictPtr); DECACHE_STACK_INFO(); objResultPtr = TclPtrSetVarIdx(interp, varPtr, NULL, NULL, NULL, - dictPtr, TCL_LEAVE_ERR_MSG, opnd2); + dictPtr, TCL_LEAVE_ERR_MSG, varIdx); CACHE_STACK_INFO(); TclDecrRefCount(dictPtr); if (objResultPtr == NULL) { @@ -6969,23 +7403,23 @@ TEBCresume( NEXT_INST_V(10, cleanup, 0); } #endif - TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); + TRACE_APPEND_OBJ(objResultPtr); NEXT_INST_V(9, cleanup, 1); case INST_DICT_APPEND: case INST_DICT_LAPPEND: - opnd = TclGetUInt4AtPtr(pc+1); - varPtr = LOCAL(opnd); + varIdx = TclGetUInt4AtPtr(pc + 1); + varPtr = LOCAL(varIdx); while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } - TRACE(("%u => ", opnd)); + TRACE(("%u => ", (unsigned)varIdx)); if (TclIsVarDirectReadable(varPtr)) { dictPtr = varPtr->value.objPtr; } else { DECACHE_STACK_INFO(); dictPtr = TclPtrGetVarIdx(interp, varPtr, NULL, NULL, NULL, 0, - opnd); + varIdx); CACHE_STACK_INFO(); } if (dictPtr == NULL) { @@ -7000,9 +7434,7 @@ TEBCresume( if (Tcl_DictObjGet(interp, dictPtr, OBJ_UNDER_TOS, &valuePtr) != TCL_OK) { - if (allocateDict) { - TclDecrRefCount(dictPtr); - } + Tcl_BounceRefCount(dictPtr); TRACE_ERROR(interp); goto gotError; } @@ -7043,15 +7475,12 @@ TEBCresume( if (valuePtr == NULL) { Tcl_DictObjPut(NULL, dictPtr, OBJ_UNDER_TOS, Tcl_NewListObj(1, &OBJ_AT_TOS)); - break; } else if (Tcl_IsShared(valuePtr)) { valuePtr = Tcl_DuplicateObj(valuePtr); if (Tcl_ListObjAppendElement(interp, valuePtr, OBJ_AT_TOS) != TCL_OK) { TclDecrRefCount(valuePtr); - if (allocateDict) { - TclDecrRefCount(dictPtr); - } + Tcl_BounceRefCount(dictPtr); TRACE_ERROR(interp); goto gotError; } @@ -7059,9 +7488,7 @@ TEBCresume( } else { if (Tcl_ListObjAppendElement(interp, valuePtr, OBJ_AT_TOS) != TCL_OK) { - if (allocateDict) { - TclDecrRefCount(dictPtr); - } + Tcl_BounceRefCount(dictPtr); TRACE_ERROR(interp); goto gotError; } @@ -7078,7 +7505,7 @@ TEBCresume( } break; default: - Tcl_Panic("Should not happen!"); + TCL_UNREACHABLE(); } if (TclIsVarDirectWritable(varPtr)) { @@ -7095,7 +7522,7 @@ TEBCresume( Tcl_IncrRefCount(dictPtr); DECACHE_STACK_INFO(); objResultPtr = TclPtrSetVarIdx(interp, varPtr, NULL, NULL, NULL, - dictPtr, TCL_LEAVE_ERR_MSG, opnd); + dictPtr, TCL_LEAVE_ERR_MSG, varIdx); CACHE_STACK_INFO(); TclDecrRefCount(dictPtr); if (objResultPtr == NULL) { @@ -7105,15 +7532,15 @@ TEBCresume( } #ifndef TCL_COMPILE_DEBUG if (pc[5] == INST_POP) { - NEXT_INST_F(6, 2, 0); + NEXT_INST_F0(6, 2); } #endif - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + TRACE_APPEND_OBJ(objResultPtr); NEXT_INST_F(5, 2, 1); case INST_DICT_FIRST: - opnd = TclGetUInt4AtPtr(pc+1); - TRACE(("%u => ", opnd)); + varIdx = TclGetUInt4AtPtr(pc + 1); + TRACE(("%u => ", (unsigned) varIdx)); dictPtr = POP_OBJECT(); searchPtr = (Tcl_DictSearch *)Tcl_Alloc(sizeof(Tcl_DictSearch)); if (Tcl_DictObjFirst(interp, dictPtr, searchPtr, &keyPtr, @@ -7136,10 +7563,11 @@ TEBCresume( ir.twoPtrValue.ptr2 = dictPtr; Tcl_StoreInternalRep(statePtr, &dictIteratorType, &ir); } - varPtr = LOCAL(opnd); + varPtr = LOCAL(varIdx); if (varPtr->value.objPtr) { if (TclHasInternalRep(varPtr->value.objPtr, &dictIteratorType)) { Tcl_Panic("mis-issued dictFirst!"); + TCL_UNREACHABLE(); } TclDecrRefCount(varPtr->value.objPtr); } @@ -7148,9 +7576,9 @@ TEBCresume( goto pushDictIteratorResult; case INST_DICT_NEXT: - opnd = TclGetUInt4AtPtr(pc+1); - TRACE(("%u => ", opnd)); - statePtr = (*LOCAL(opnd)).value.objPtr; + varIdx = TclGetUInt4AtPtr(pc + 1); + TRACE(("%u => ", (unsigned)varIdx)); + statePtr = (*LOCAL(varIdx)).value.objPtr; { const Tcl_ObjInternalRep *irPtr; @@ -7160,6 +7588,7 @@ TEBCresume( Tcl_DictObjNext(searchPtr, &keyPtr, &valuePtr, &done); } else { Tcl_Panic("mis-issued dictNext!"); + TCL_UNREACHABLE(); } } pushDictIteratorResult: @@ -7184,11 +7613,11 @@ TEBCresume( JUMP_PEEPHOLE_F(done, 5, 0); case INST_DICT_UPDATE_START: - opnd = TclGetUInt4AtPtr(pc+1); - opnd2 = TclGetUInt4AtPtr(pc+5); - TRACE(("%u => ", opnd)); - varPtr = LOCAL(opnd); - duiPtr = (DictUpdateInfo *)codePtr->auxDataArrayPtr[opnd2].clientData; + varIdx = TclGetUInt4AtPtr(pc + 1); + tblIdx = TclGetUInt4AtPtr(pc + 5); + TRACE(("%u %u => ", (unsigned)varIdx, tblIdx)); + varPtr = LOCAL(varIdx); + duiPtr = (DictUpdateInfo *)codePtr->auxDataArrayPtr[tblIdx].clientData; while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } @@ -7197,7 +7626,7 @@ TEBCresume( } else { DECACHE_STACK_INFO(); dictPtr = TclPtrGetVarIdx(interp, varPtr, NULL, NULL, NULL, - TCL_LEAVE_ERR_MSG, opnd); + TCL_LEAVE_ERR_MSG, varIdx); CACHE_STACK_INFO(); if (dictPtr == NULL) { TRACE_ERROR(interp); @@ -7212,6 +7641,7 @@ TEBCresume( } if (length != duiPtr->length) { Tcl_Panic("dictUpdateStart argument length mismatch"); + TCL_UNREACHABLE(); } for (i=0 ; i<length ; i++) { if (Tcl_DictObjGet(interp, dictPtr, keyPtrPtr[i], @@ -7241,14 +7671,14 @@ TEBCresume( } TclDecrRefCount(dictPtr); TRACE_APPEND(("OK\n")); - NEXT_INST_F(9, 0, 0); + NEXT_INST_F0(9, 0); case INST_DICT_UPDATE_END: - opnd = TclGetUInt4AtPtr(pc+1); - opnd2 = TclGetUInt4AtPtr(pc+5); - TRACE(("%u => ", opnd)); - varPtr = LOCAL(opnd); - duiPtr = (DictUpdateInfo *)codePtr->auxDataArrayPtr[opnd2].clientData; + varIdx = TclGetUInt4AtPtr(pc + 1); + tblIdx = TclGetUInt4AtPtr(pc + 5); + TRACE(("%u %u => ", (unsigned)varIdx, tblIdx)); + varPtr = LOCAL(varIdx); + duiPtr = (DictUpdateInfo *)codePtr->auxDataArrayPtr[tblIdx].clientData; while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } @@ -7257,12 +7687,12 @@ TEBCresume( } else { DECACHE_STACK_INFO(); dictPtr = TclPtrGetVarIdx(interp, varPtr, NULL, NULL, NULL, 0, - opnd); + varIdx); CACHE_STACK_INFO(); } if (dictPtr == NULL) { TRACE_APPEND(("storage was unset\n")); - NEXT_INST_F(9, 1, 0); + NEXT_INST_F0(9, 1); } if (Tcl_DictObjSize(interp, dictPtr, &length) != TCL_OK || TclListObjGetElements(interp, OBJ_AT_TOS, &length, @@ -7307,7 +7737,7 @@ TEBCresume( } else { DECACHE_STACK_INFO(); objResultPtr = TclPtrSetVarIdx(interp, varPtr, NULL, NULL, NULL, - dictPtr, TCL_LEAVE_ERR_MSG, opnd); + dictPtr, TCL_LEAVE_ERR_MSG, varIdx); CACHE_STACK_INFO(); if (objResultPtr == NULL) { if (allocdict) { @@ -7318,7 +7748,7 @@ TEBCresume( } } TRACE_APPEND(("written back\n")); - NEXT_INST_F(9, 1, 0); + NEXT_INST_F0(9, 1); case INST_DICT_EXPAND: dictPtr = OBJ_UNDER_TOS; @@ -7333,7 +7763,7 @@ TEBCresume( TRACE_ERROR(interp); goto gotError; } - TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); + TRACE_APPEND_OBJ(objResultPtr); NEXT_INST_F(1, 2, 1); case INST_DICT_RECOMBINE_STK: @@ -7364,14 +7794,14 @@ TEBCresume( goto gotError; } TRACE_APPEND(("OK\n")); - NEXT_INST_F(1, 2, 0); + NEXT_INST_F0(1, 2); case INST_DICT_RECOMBINE_IMM: - opnd = TclGetUInt4AtPtr(pc+1); + varIdx = TclGetUInt4AtPtr(pc + 1); listPtr = OBJ_UNDER_TOS; keysPtr = OBJ_AT_TOS; - varPtr = LOCAL(opnd); - TRACE(("%u <- \"%.30s\" \"%.30s\" => ", opnd, O2S(valuePtr), + varPtr = LOCAL(varIdx); + TRACE(("%u <- \"%.30s\" \"%.30s\" => ", (unsigned)varIdx, O2S(valuePtr), O2S(keysPtr))); if (TclListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) { TRACE_ERROR(interp); @@ -7381,7 +7811,7 @@ TEBCresume( varPtr = varPtr->value.linkPtr; } DECACHE_STACK_INFO(); - result = TclDictWithFinish(interp, varPtr, NULL, NULL, NULL, opnd, + result = TclDictWithFinish(interp, varPtr, NULL, NULL, NULL, varIdx, objc, objv, keysPtr); CACHE_STACK_INFO(); if (result != TCL_OK) { @@ -7389,9 +7819,8 @@ TEBCresume( goto gotError; } TRACE_APPEND(("OK\n")); - NEXT_INST_F(5, 2, 0); + NEXT_INST_F0(5, 2); } - break; /* * End of dictionary-related instructions. @@ -7401,35 +7830,34 @@ TEBCresume( case INST_CLOCK_READ: { /* Read the wall clock */ Tcl_WideInt wval; Tcl_Time now; - switch (TclGetUInt1AtPtr(pc+1)) { - case 0: /* clicks */ + switch (TclGetUInt1AtPtr(pc + 1)) { + case CLOCK_READ_CLICKS: #ifdef TCL_WIDE_CLICKS wval = TclpGetWideClicks(); #else wval = (Tcl_WideInt)TclpGetClicks(); #endif break; - case 1: /* microseconds */ + case CLOCK_READ_MICROS: Tcl_GetTime(&now); wval = (Tcl_WideInt)now.sec * 1000000 + now.usec; break; - case 2: /* milliseconds */ + case CLOCK_READ_MILLIS: Tcl_GetTime(&now); wval = (Tcl_WideInt)now.sec * 1000 + now.usec / 1000; break; - case 3: /* seconds */ + case CLOCK_READ_SECS: Tcl_GetTime(&now); wval = (Tcl_WideInt)now.sec; break; default: Tcl_Panic("clockRead instruction with unknown clock#"); - break; + TCL_UNREACHABLE(); } TclNewIntObj(objResultPtr, wval); TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(2, 0, 1); } - break; default: Tcl_Panic("TclNRExecuteByteCode: unrecognized opCode %u", *pc); @@ -7456,13 +7884,18 @@ TEBCresume( processExceptionReturn: #ifdef TCL_COMPILE_DEBUG switch (*pc) { +#ifndef REMOVE_DEPRECATED_OPCODES case INST_INVOKE_STK1: - opnd = TclGetUInt1AtPtr(pc+1); - TRACE(("%u => ... after \"%.20s\": ", opnd, cmdNameBuf)); + numArgs = TclGetUInt1AtPtr(pc + 1); + TRACE(("%u => ... after \"%.20s\": ", (unsigned)numArgs, cmdNameBuf)); + break; +#endif // REMOVE_DEPRECATED_OPCODES + case INST_INVOKE_STK: + numArgs = TclGetUInt4AtPtr(pc + 1); + TRACE(("%u => ... after \"%.20s\": ", (unsigned)numArgs, cmdNameBuf)); break; - case INST_INVOKE_STK4: - opnd = TclGetUInt4AtPtr(pc+1); - TRACE(("%u => ... after \"%.20s\": ", opnd, cmdNameBuf)); + case INST_INVOKE_EXPANDED: + TRACE((" => ... after \"%.20s\": ", cmdNameBuf)); break; case INST_EVAL_STK: /* @@ -7494,10 +7927,10 @@ TEBCresume( if (result == TCL_BREAK) { result = TCL_OK; pc = (codePtr->codeStart + rangePtr->breakOffset); - TRACE_APPEND(("%s, range at %" TCL_SIZE_MODIFIER "d, new pc %" TCL_SIZE_MODIFIER "d\n", + TRACE_APPEND(("%s, range at %" SIZEd ", new pc %" SIZEd "\n", StringForResultCode(result), rangePtr->codeOffset, rangePtr->breakOffset)); - NEXT_INST_F(0, 0, 0); + NEXT_INST_F0(0, 0); } if (rangePtr->continueOffset == TCL_INDEX_NONE) { TRACE_APPEND(("%s, loop w/o continue, checking for catch\n", @@ -7506,10 +7939,10 @@ TEBCresume( } result = TCL_OK; pc = (codePtr->codeStart + rangePtr->continueOffset); - TRACE_APPEND(("%s, range at %" TCL_SIZE_MODIFIER "d, new pc %" TCL_SIZE_MODIFIER "d\n", + TRACE_APPEND(("%s, range at %" SIZEd ", new pc %" SIZEd "\n", StringForResultCode(result), rangePtr->codeOffset, rangePtr->continueOffset)); - NEXT_INST_F(0, 0, 0); + NEXT_INST_F0(0, 0); } #ifdef TCL_COMPILE_DEBUG if (traceInstructions) { @@ -7678,14 +8111,14 @@ TEBCresume( } #ifdef TCL_COMPILE_DEBUG if (traceInstructions) { - fprintf(stdout, " ... found catch at %" TCL_SIZE_MODIFIER "d, catchTop=%" TCL_T_MODIFIER "d, " - "unwound to %" TCL_T_MODIFIER "d, new pc %" TCL_SIZE_MODIFIER "d\n", - rangePtr->codeOffset, (catchTop - initCatchTop - 1), + fprintf(stdout, " ... found catch at %" SIZEd ", catchTop=%" SIZEd ", " + "unwound to %" SIZEd ", new pc %" SIZEd "\n", + rangePtr->codeOffset, (Tcl_Size) (catchTop - initCatchTop - 1), PTR2INT(*catchTop), rangePtr->catchOffset); } #endif pc = (codePtr->codeStart + rangePtr->catchOffset); - NEXT_INST_F(0, 0, 0); /* Restart the execution loop at pc. */ + NEXT_INST_F0(0, 0); /* Restart the execution loop at pc. */ /* * end of infinite loop dispatching on instructions. @@ -7716,11 +8149,12 @@ TEBCresume( } if (tosPtr < initTosPtr) { +#ifdef TCL_COMPILE_DEBUG fprintf(stderr, - "\nTclNRExecuteByteCode: abnormal return at pc %" TCL_T_MODIFIER "d: " - "stack top %" TCL_SIZE_MODIFIER "d < entry stack top %d\n", - (pc - codePtr->codeStart), - CURR_DEPTH, 0); + "\nTclNRExecuteByteCode: abnormal return at pc %" SIZEd ": " + "stack top %" SIZEd " < entry stack top %d\n", + PC_REL, CURR_DEPTH, 0); +#endif Tcl_Panic("TclNRExecuteByteCode execution failure: end stack top < start stack top"); } CLANG_ASSERT(bcFramePtr); @@ -7735,43 +8169,37 @@ TEBCresume( /* * 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. + * 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; - Tcl_Size xxx1length; - - xxx1length = 0; - - if (TclInterpReady(interp) == TCL_ERROR) { - goto gotError; - } + instStartCmdFailed: + if (TclInterpReady(interp) == TCL_ERROR) { + goto gotError; + } - /* - * 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], bug [fa6bf38d07] - * - * TODO: recompile, search this command and eval a code starting from, - * so that this evaluation does not add a new TEBC instance without - * NRE-trampoline. - */ + /* + * 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], bug [fa6bf38d07] + * + * TODO: recompile, search this command and eval a code starting from, + * so that this evaluation does not add a new TEBC instance without + * NRE-trampoline. + */ - codePtr->flags |= TCL_BYTECODE_RECOMPILE; - bytes = GetSrcInfoForPc(pc, codePtr, &xxx1length, NULL, NULL); - opnd = TclGetUInt4AtPtr(pc+1); - pc += (opnd-1); - assert(bytes); - PUSH_OBJECT(Tcl_NewStringObj(bytes, xxx1length)); - goto instEvalStk; - } + codePtr->flags |= TCL_BYTECODE_RECOMPILE; + Tcl_Size xxx1length = 0; + const char *bytes = GetSrcInfoForPc(pc, codePtr, &xxx1length, NULL, NULL); + unsigned offset = TclGetUInt4AtPtr(pc + 1); + pc += offset - 1; + assert(bytes); + PUSH_OBJECT(Tcl_NewStringObj(bytes, xxx1length)); + goto instEvalStk; } #undef codePtr @@ -7957,26 +8385,26 @@ ExecuteExtendedBinaryMathOp( Tcl_Obj *value2Ptr) /* The second operand on the stack. */ { #define WIDE_RESULT(w) \ - if (Tcl_IsShared(valuePtr)) { \ - return Tcl_NewWideIntObj(w); \ - } else { \ - TclSetIntObj(valuePtr, (w)); \ - return NULL; \ + if (Tcl_IsShared(valuePtr)) { \ + return Tcl_NewWideIntObj(w); \ + } else { \ + TclSetIntObj(valuePtr, (w)); \ + return NULL; \ } #define BIG_RESULT(b) \ - if (Tcl_IsShared(valuePtr)) { \ - return Tcl_NewBignumObj(b); \ - } else { \ - Tcl_SetBignumObj(valuePtr, (b)); \ - return NULL; \ + if (Tcl_IsShared(valuePtr)) { \ + return Tcl_NewBignumObj(b); \ + } else { \ + Tcl_SetBignumObj(valuePtr, (b)); \ + return NULL; \ } #define DOUBLE_RESULT(d) \ - if (Tcl_IsShared(valuePtr)) { \ - TclNewDoubleObj(objResultPtr, (d)); \ - return objResultPtr; \ - } else { \ - Tcl_SetDoubleObj(valuePtr, (d)); \ - return NULL; \ + if (Tcl_IsShared(valuePtr)) { \ + TclNewDoubleObj(objResultPtr, (d)); \ + return objResultPtr; \ + } else { \ + Tcl_SetDoubleObj(valuePtr, (d)); \ + return NULL; \ } int type1, type2; @@ -8109,8 +8537,7 @@ ExecuteExtendedBinaryMathOp( mp_clear(&big2); break; default: - /* Unused, here to silence compiler warning */ - invalid = 0; + TCL_UNREACHABLE(); } if (invalid) { Tcl_SetObjResult(interp, Tcl_NewStringObj( @@ -8187,8 +8614,7 @@ ExecuteExtendedBinaryMathOp( mp_clear(&big1); break; default: - /* Unused, here to silence compiler warning. */ - zero = 0; + TCL_UNREACHABLE(); } if (zero) { return constants[0]; @@ -8244,14 +8670,14 @@ ExecuteExtendedBinaryMathOp( case INST_BITAND: err = mp_and(&big1, &big2, &bigResult); break; - case INST_BITOR: err = mp_or(&big1, &big2, &bigResult); break; - case INST_BITXOR: err = mp_xor(&big1, &big2, &bigResult); break; + default: + TCL_UNREACHABLE(); } } if (err != MP_OKAY) { @@ -8277,8 +8703,7 @@ ExecuteExtendedBinaryMathOp( wResult = w1 ^ w2; break; default: - /* Unused, here to silence compiler warning. */ - wResult = 0; + TCL_UNREACHABLE(); } WIDE_RESULT(wResult); @@ -8338,7 +8763,7 @@ ExecuteExtendedBinaryMathOp( if (oddExponent) { WIDE_RESULT(-1); } - /* fallthrough */ + TCL_FALLTHROUGH(); case 1: /* * 1 to any power is 1. @@ -8349,7 +8774,6 @@ ExecuteExtendedBinaryMathOp( } } if (negativeExponent) { - /* * Integers with magnitude greater than 1 raise to a negative * power yield the answer zero (see TIP 123). @@ -8362,23 +8786,23 @@ ExecuteExtendedBinaryMathOp( } switch (w1) { - case 0: - /* - * Zero to a positive power is zero. - */ + case 0: + /* + * Zero to a positive power is zero. + */ - return constants[0]; - case 1: - /* - * 1 to any power is 1. - */ + return constants[0]; + case 1: + /* + * 1 to any power is 1. + */ + return constants[1]; + case -1: + if (!oddExponent) { return constants[1]; - case -1: - if (!oddExponent) { - return constants[1]; - } - WIDE_RESULT(-1); + } + WIDE_RESULT(-1); } /* @@ -8526,8 +8950,7 @@ ExecuteExtendedBinaryMathOp( dResult = d1 / d2; break; default: - /* Unused, here to silence compiler warning. */ - dResult = 0; + TCL_UNREACHABLE(); } doubleResult: @@ -8615,11 +9038,7 @@ ExecuteExtendedBinaryMathOp( break; default: - /* - * Unused, here to silence compiler warning. - */ - - wResult = 0; + TCL_UNREACHABLE(); } WIDE_RESULT(wResult); @@ -8670,10 +9089,10 @@ ExecuteExtendedBinaryMathOp( mp_clear(&big1); mp_clear(&big2); BIG_RESULT(&bigResult); + default: + Tcl_Panic("unexpected opcode"); + TCL_UNREACHABLE(); } - - Tcl_Panic("unexpected opcode"); - return NULL; } static Tcl_Obj * @@ -8728,10 +9147,10 @@ ExecuteExtendedUnaryMathOp( return OUT_OF_MEMORY; } BIG_RESULT(&big); + default: + Tcl_Panic("unexpected opcode"); + TCL_UNREACHABLE(); } - - Tcl_Panic("unexpected opcode"); - return NULL; } #undef WIDE_RESULT #undef BIG_RESULT @@ -8821,8 +9240,9 @@ TclCompareTwoNumbers( } mp_clear(&big2); return compare; + default: + TCL_UNREACHABLE(); } - break; case TCL_NUMBER_DOUBLE: d1 = *((const double *)ptr1); @@ -8868,8 +9288,9 @@ TclCompareTwoNumbers( } Tcl_InitBignumFromDouble(NULL, d1, &big1); goto bigCompare; + default: + TCL_UNREACHABLE(); } - break; case TCL_NUMBER_BIG: Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); @@ -8905,14 +9326,211 @@ TclCompareTwoNumbers( mp_clear(&big1); mp_clear(&big2); return compare; + default: + TCL_UNREACHABLE(); } - break; default: Tcl_Panic("unexpected number type"); + TCL_UNREACHABLE(); } return TCL_ERROR; } +/* + *---------------------------------------------------------------------- + * + * ParseArithSeriesArgument -- + * + * Helper for GenerateArithSeries() that encapsulates the weird calling of + * Tcl_ExprObj() if the value isn't numeric. + * + * Results: + * TCL_OK if the value was numeric or a numeric-yielding expression, or + * TCL_ERROR if not. The variables pointed at by ptrPtr and typePtr will + * be updated on OK, the interpreter result on ERROR. + * + * Side effects: + * Can call Tcl_ExprObj() which can call commands, so arbitrary side + * effects are possible. May update the variable pointed at by valuePtr + * to contain the expression result. + * + *---------------------------------------------------------------------- + */ +static inline int +ParseArithSeriesArgument( + Tcl_Interp *interp, // The interpreter. + Tcl_Obj **valuePtr, // Var holding object reference to parse/update [IN/OUT] + void **ptrPtr, // Var to receive ref to number contents [OUT] + int *typePtr) // Var to receive number type [OUT] +{ + Tcl_Obj *value = *valuePtr, *tmp; + if (TclHasInternalRep(value, &tclExprCodeType) + || GetNumberFromObj(NULL, value, ptrPtr, typePtr) != TCL_OK) { + if (Tcl_ExprObj(interp, value, &tmp) != TCL_OK) { + return TCL_ERROR; + } + // Switch to the object out of the expression. + Tcl_DecrRefCount(value); + *valuePtr = value = tmp; + if (GetNumberFromObj(interp, value, ptrPtr, typePtr) != TCL_OK) { + return TCL_ERROR; + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * GenerateArithSeries -- + * + * This is the core of the implementation of the INST_ARITH_SERIES opcode, + * handling the decoding of the arguments (applying Tcl_ExprObj() if + * necessary) before handing off to TclNewArithSeriesObj() to build the + * series. + * + * Results: + * The arithmetic series object (zero refcount) or NULL on error, when a + * message will be left in the interpreter result. + * + * Side effects: + * Can call Tcl_ExprObj() which can call commands, so arbitrary side + * effects are possible. + * + *---------------------------------------------------------------------- + */ +static Tcl_Obj * +GenerateArithSeries( + Tcl_Interp *interp, // The interpreter. + Tcl_Obj *from, // The from value, or NULL if not supplied. + Tcl_Obj *to, // The to value, or NULL if not supplied. + Tcl_Obj *step, // The step value, or NULL if not supplied. + Tcl_Obj *count) // The count value, or NULL if not supplied. +{ + Tcl_Obj *result = NULL; + int type, useDoubles = 0; + void *ptr; + + // Hold explicit references. + if (from) { + Tcl_IncrRefCount(from); + } + if (to) { + Tcl_IncrRefCount(to); + } + if (step) { + Tcl_IncrRefCount(step); + } + if (count) { + Tcl_IncrRefCount(count); + } + + /* + * Decide whether to request a double series or an int series. + * Note the calls to Tcl_ExprObj. UGH! + */ + + if (from) { + if (ParseArithSeriesArgument(interp, &from, &ptr, &type) != TCL_OK) { + goto cleanupOnError; + } + switch (type) { + case TCL_NUMBER_DOUBLE: + useDoubles = 1; + break; + case TCL_NUMBER_NAN: + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "domain error: argument not in valid range")); + Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", + "domain error: argument not in valid range", NULL); + goto cleanupOnError; + } + } + + if (to) { + if (ParseArithSeriesArgument(interp, &to, &ptr, &type) != TCL_OK) { + goto cleanupOnError; + } + switch (type) { + case TCL_NUMBER_DOUBLE: + useDoubles = 1; + break; + case TCL_NUMBER_NAN: + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "cannot use non-numeric floating-point value \"%s\" to " + "estimate length of arith-series", + TclGetString(to))); + Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", + "domain error: argument not in valid range", NULL); + goto cleanupOnError; + } + } + + if (step) { + if (ParseArithSeriesArgument(interp, &step, &ptr, &type) != TCL_OK) { + goto cleanupOnError; + } + switch (type) { + case TCL_NUMBER_DOUBLE: + useDoubles = 1; + break; + case TCL_NUMBER_NAN: + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "domain error: argument not in valid range")); + Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", + "domain error: argument not in valid range", NULL); + goto cleanupOnError; + } + } + + // Convert count to integer if not already + // Almost the same as above cases except how floats are really handled. + if (count) { + if (ParseArithSeriesArgument(interp, &count, &ptr, &type) != TCL_OK) { + goto cleanupOnError; + } + switch (type) { + case TCL_NUMBER_DOUBLE: { + double dCount = *((const double *) ptr); + Tcl_WideInt wCount = (Tcl_WideInt) dCount; + if (dCount - wCount == 0.0) { + Tcl_DecrRefCount(count); + // Switch to the object holding integer version of the count. + TclNewIntObj(count, wCount); + Tcl_IncrRefCount(count); + } + break; + } + case TCL_NUMBER_NAN: + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "expected integer but got \"%s\"", + TclGetString(count))); + Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", + "domain error: argument not in valid range", NULL); + goto cleanupOnError; + } + } + + // Parameters comprehended and normalised. Now construct the series. + result = TclNewArithSeriesObj(interp, useDoubles, from, to, step, count); + + // Clean up and return. + cleanupOnError: + if (count) { + Tcl_DecrRefCount(count); + } + if (step) { + Tcl_DecrRefCount(step); + } + if (to) { + Tcl_DecrRefCount(to); + } + if (from) { + Tcl_DecrRefCount(from); + } + return result; +} + #ifdef TCL_COMPILE_DEBUG /* *---------------------------------------------------------------------- @@ -8941,19 +9559,17 @@ PrintByteCodeInfo( Interp *iPtr = (Interp *) *codePtr->interpHandle; fprintf(stdout, - "\nExecuting ByteCode 0x%p, refCt %" TCL_Z_MODIFIER - "u, epoch %" TCL_Z_MODIFIER "u, interp 0x%p (epoch %" - TCL_Z_MODIFIER "u)\n", + "\nExecuting ByteCode 0x%p, refCt %" SIZEu ", epoch %" SIZEu ", " + "interp 0x%p (epoch %" SIZEu ")\n", codePtr, codePtr->refCount, codePtr->compileEpoch, iPtr, iPtr->compileEpoch); fprintf(stdout, " Source: "); TclPrintSource(stdout, codePtr->source, 60); fprintf(stdout, - "\n Cmds %" TCL_Z_MODIFIER "u, src %" TCL_Z_MODIFIER - "u, inst %" TCL_Z_MODIFIER "u, litObjs %" TCL_Z_MODIFIER - "u, aux %" TCL_Z_MODIFIER "u, stkDepth %" TCL_Z_MODIFIER - "u, code/src %.2f\n", + "\n Cmds %" SIZEd ", src %" SIZEd ", inst %" SIZEd ", " + "litObjs %" SIZEd ", aux %" SIZEd ", stkDepth %" SIZEd ", " + "code/src %.2f\n", codePtr->numCommands, codePtr->numSrcBytes, codePtr->numCodeBytes, codePtr->numLitObjects, codePtr->numAuxDataItems, codePtr->maxStackDepth, @@ -8965,10 +9581,9 @@ PrintByteCodeInfo( #ifdef TCL_COMPILE_STATS fprintf(stdout, - " Code %" TCL_Z_MODIFIER "u = header %" TCL_Z_MODIFIER - "u+inst %" TCL_Z_MODIFIER "u+litObj %" TCL_Z_MODIFIER - "u+exc %" TCL_Z_MODIFIER "u+aux %" TCL_Z_MODIFIER - "u+cmdMap %" TCL_Z_MODIFIER "u\n", + " Code %" SIZEu " = header %" SIZEu "+inst %" SIZEd + "+litObj %" SIZEu "+exc %" SIZEu "+aux %" SIZEu + "+cmdMap %" SIZEd "\n", codePtr->structureSize, offsetof(ByteCode, localCachePtr), codePtr->numCodeBytes, @@ -8979,8 +9594,8 @@ PrintByteCodeInfo( #endif /* TCL_COMPILE_STATS */ if (procPtr != NULL) { fprintf(stdout, - " Proc 0x%p, refCt %" TCL_Z_MODIFIER "u, args %" - TCL_Z_MODIFIER "u, compiled locals %" TCL_Z_MODIFIER "u\n", + " Proc 0x%p, refCt %" SIZEd ", args %" SIZEd ", " + "compiled locals %" SIZEd "\n", procPtr, procPtr->refCount, procPtr->numArgs, procPtr->numCompiledLocals); } @@ -9021,7 +9636,7 @@ ValidatePcAndStackTop( { size_t stackUpperBound = codePtr->maxStackDepth; /* Greatest legal value for stackTop. */ - size_t relativePc = (size_t)(pc - codePtr->codeStart); + size_t relativePc = (size_t) PC_REL; size_t codeStart = (size_t)codePtr->codeStart; size_t codeEnd = (size_t) (codePtr->codeStart + codePtr->numCodeBytes); @@ -9033,7 +9648,7 @@ ValidatePcAndStackTop( Tcl_Panic("TclNRExecuteByteCode execution failure: bad pc"); } if (opCode >= LAST_INST_OPCODE) { - fprintf(stderr, "\nBad opcode %u at pc %" TCL_Z_MODIFIER "u in TclNRExecuteByteCode\n", + fprintf(stderr, "\nBad opcode %u at pc %" SIZEu " in TclNRExecuteByteCode\n", opCode, relativePc); Tcl_Panic("TclNRExecuteByteCode execution failure: bad opcode"); } @@ -9041,7 +9656,8 @@ ValidatePcAndStackTop( Tcl_Size numChars; const char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars, NULL, NULL); - fprintf(stderr, "\nBad stack top %" TCL_Z_MODIFIER "u at pc %" TCL_Z_MODIFIER "u in TclNRExecuteByteCode (min 0, max %" TCL_Z_MODIFIER "u)", + fprintf(stderr, "\nBad stack top %" SIZEu " at pc %" SIZEu " in " + "TclNRExecuteByteCode (min 0, max %" SIZEu ")", stackTop, relativePc, stackUpperBound); if (cmd != NULL) { Tcl_Obj *message; @@ -9264,7 +9880,7 @@ GetSrcInfoForPc( * of the command containing the pc should * be stored. */ { - Tcl_Size pcOffset = pc - codePtr->codeStart; + Tcl_Size pcOffset = PC_REL; Tcl_Size numCmds = codePtr->numCommands; unsigned char *codeDeltaNext, *codeLengthNext; unsigned char *srcDeltaNext, *srcLengthNext; @@ -9332,7 +9948,7 @@ GetSrcInfoForPc( break; } if (pcOffset <= codeEnd) { /* This cmd's code encloses pc */ - int dist = (pcOffset - codeOffset); + Tcl_Size dist = (pcOffset - codeOffset); if (dist <= bestDist) { bestDist = dist; @@ -9418,7 +10034,7 @@ GetExceptRangeForPc( ExceptionRange *rangeArrayPtr; size_t numRanges = codePtr->numExceptRanges; ExceptionRange *rangePtr; - size_t pcOffset = pc - codePtr->codeStart; + size_t pcOffset = PC_REL; size_t start; if (numRanges == 0) { @@ -9443,7 +10059,8 @@ GetExceptRangeForPc( if (searchMode == TCL_BREAK) { return rangePtr; } - if (searchMode == TCL_CONTINUE && rangePtr->continueOffset != TCL_INDEX_NONE){ + if (searchMode == TCL_CONTINUE + && rangePtr->continueOffset != TCL_INDEX_NONE) { return rangePtr; } } @@ -9551,13 +10168,13 @@ TclExprFloatError( int TclLog2( - long long value) /* The integer for which to compute the log + long long value) /* The integer for which to compute the log * base 2. The maximum output is 31 */ { - return (value > 0) ? ( - (value > 0x7FFFFFFF) ? - 31 : TclMSB((unsigned long long) value) - ) : 0; + return (value > 0) ? ( + (value > 0x7FFFFFFF) ? + 31 : TclMSB((unsigned long long) value) + ) : 0; } /* @@ -9641,9 +10258,9 @@ EvalStatsCmd( "Compilation and execution statistics for interpreter %p\n", iPtr); - Tcl_AppendPrintfToObj(objPtr, "\nNumber ByteCodes executed\t%" TCL_Z_MODIFIER "u\n", + Tcl_AppendPrintfToObj(objPtr, "\nNumber ByteCodes executed\t%" SIZEu "\n", statsPtr->numExecutions); - Tcl_AppendPrintfToObj(objPtr, "Number ByteCodes compiled\t%" TCL_Z_MODIFIER "u\n", + Tcl_AppendPrintfToObj(objPtr, "Number ByteCodes compiled\t%" SIZEu "\n", statsPtr->numCompilations); Tcl_AppendPrintfToObj(objPtr, " Mean executions/compile\t%.1f\n", statsPtr->numExecutions / (float)statsPtr->numCompilations); @@ -9655,7 +10272,7 @@ EvalStatsCmd( Tcl_AppendPrintfToObj(objPtr, " Mean inst/execution\t\t%.0f\n", numInstructions / statsPtr->numExecutions); - Tcl_AppendPrintfToObj(objPtr, "\nTotal ByteCodes\t\t\t%" TCL_Z_MODIFIER "u\n", + Tcl_AppendPrintfToObj(objPtr, "\nTotal ByteCodes\t\t\t%" SIZEu "\n", statsPtr->numCompilations); Tcl_AppendPrintfToObj(objPtr, " Source bytes\t\t\t%.6g\n", statsPtr->totalSrcBytes); @@ -9665,7 +10282,8 @@ EvalStatsCmd( statsPtr->totalByteCodeBytes); Tcl_AppendPrintfToObj(objPtr, " Literal bytes\t\t%.6g\n", totalLiteralBytes); - Tcl_AppendPrintfToObj(objPtr, " table %" TCL_Z_MODIFIER "u + bkts %" TCL_Z_MODIFIER "u + entries %" TCL_Z_MODIFIER "u + objects %" TCL_Z_MODIFIER "u + strings %.6g\n", + Tcl_AppendPrintfToObj(objPtr, " table %" SIZEu " + bkts %" SIZEu + " + entries %" SIZEu " + objects %" SIZEu " + strings %.6g\n", sizeof(LiteralTable), iPtr->literalTable.numBuckets * sizeof(LiteralEntry *), statsPtr->numLiteralsCreated * sizeof(LiteralEntry), @@ -9676,7 +10294,7 @@ EvalStatsCmd( Tcl_AppendPrintfToObj(objPtr, " Mean code/source\t\t%.1f\n", totalCodeBytes / statsPtr->totalSrcBytes); - Tcl_AppendPrintfToObj(objPtr, "\nCurrent (active) ByteCodes\t%" TCL_Z_MODIFIER "u\n", + Tcl_AppendPrintfToObj(objPtr, "\nCurrent (active) ByteCodes\t%" SIZEu "\n", numCurrentByteCodes); Tcl_AppendPrintfToObj(objPtr, " Source bytes\t\t\t%.6g\n", statsPtr->currentSrcBytes); @@ -9686,7 +10304,8 @@ EvalStatsCmd( statsPtr->currentByteCodeBytes); Tcl_AppendPrintfToObj(objPtr, " Literal bytes\t\t%.6g\n", currentLiteralBytes); - Tcl_AppendPrintfToObj(objPtr, " table %" TCL_Z_MODIFIER "u + bkts %" TCL_Z_MODIFIER "u + entries %" TCL_Z_MODIFIER "u + objects %" TCL_Z_MODIFIER "u + strings %.6g\n", + Tcl_AppendPrintfToObj(objPtr, " table %" SIZEu " + bkts %" SIZEu + " + entries %" SIZEu " + objects %" SIZEu " + strings %.6g\n", sizeof(LiteralTable), iPtr->literalTable.numBuckets * sizeof(LiteralEntry *), iPtr->literalTable.numEntries * sizeof(LiteralEntry), @@ -9707,17 +10326,17 @@ EvalStatsCmd( numSharedMultX = 0; Tcl_AppendPrintfToObj(objPtr, "\nTcl_IsShared object check (all objects):\n"); - Tcl_AppendPrintfToObj(objPtr, " Object had refcount <=1 (not shared)\t%" TCL_Z_MODIFIER "u\n", + Tcl_AppendPrintfToObj(objPtr, " Object had refcount <=1 (not shared)\t%" SIZEu "\n", tclObjsShared[1]); for (i = 2; i < TCL_MAX_SHARED_OBJ_STATS; i++) { - Tcl_AppendPrintfToObj(objPtr, " refcount ==%" TCL_Z_MODIFIER "u\t\t%" TCL_Z_MODIFIER "u\n", + Tcl_AppendPrintfToObj(objPtr, " refcount ==%" SIZEd "\t\t%" SIZEu "\n", i, tclObjsShared[i]); numSharedMultX += tclObjsShared[i]; } - Tcl_AppendPrintfToObj(objPtr, " refcount >=%" TCL_Z_MODIFIER "u\t\t%" TCL_Z_MODIFIER "u\n", + Tcl_AppendPrintfToObj(objPtr, " refcount >=%" SIZEd "\t\t%" SIZEu "\n", i, tclObjsShared[0]); numSharedMultX += tclObjsShared[0]; - Tcl_AppendPrintfToObj(objPtr, " Total shared objects\t\t\t%" TCL_Z_MODIFIER "u\n", + Tcl_AppendPrintfToObj(objPtr, " Total shared objects\t\t\t%" SIZEu "\n", numSharedMultX); /* @@ -9741,33 +10360,33 @@ EvalStatsCmd( (void) TclGetStringFromObj(entryPtr->objPtr, &length); refCountSum += entryPtr->refCount; objBytesIfUnshared += (entryPtr->refCount * sizeof(Tcl_Obj)); - strBytesIfUnshared += (entryPtr->refCount * (length+1)); + strBytesIfUnshared += (entryPtr->refCount * (length + 1)); if (entryPtr->refCount > 1) { numSharedMultX++; - strBytesSharedMultX += (length+1); + strBytesSharedMultX += (length + 1); } else { numSharedOnce++; - strBytesSharedOnce += (length+1); + strBytesSharedOnce += (length + 1); } } } sharingBytesSaved = (objBytesIfUnshared + strBytesIfUnshared) - currentLiteralBytes; - Tcl_AppendPrintfToObj(objPtr, "\nTotal objects (all interps)\t%" TCL_Z_MODIFIER "u\n", + Tcl_AppendPrintfToObj(objPtr, "\nTotal objects (all interps)\t%" SIZEu "\n", tclObjsAlloced); - Tcl_AppendPrintfToObj(objPtr, "Current objects\t\t\t%" TCL_Z_MODIFIER "u\n", + Tcl_AppendPrintfToObj(objPtr, "Current objects\t\t\t%" SIZEu "\n", (tclObjsAlloced - tclObjsFreed)); - Tcl_AppendPrintfToObj(objPtr, "Total literal objects\t\t%" TCL_Z_MODIFIER "u\n", + Tcl_AppendPrintfToObj(objPtr, "Total literal objects\t\t%" SIZEu "\n", statsPtr->numLiteralsCreated); - Tcl_AppendPrintfToObj(objPtr, "\nCurrent literal objects\t\t%" TCL_SIZE_MODIFIER "d (%0.1f%% of current objects)\n", + Tcl_AppendPrintfToObj(objPtr, "\nCurrent literal objects\t\t%" SIZEu " (%0.1f%% of current objects)\n", globalTablePtr->numEntries, Percent(globalTablePtr->numEntries, tclObjsAlloced-tclObjsFreed)); - Tcl_AppendPrintfToObj(objPtr, " ByteCode literals\t\t%" TCL_Z_MODIFIER "u (%0.1f%% of current literals)\n", + Tcl_AppendPrintfToObj(objPtr, " ByteCode literals\t\t%" SIZEu " (%0.1f%% of current literals)\n", numByteCodeLits, Percent(numByteCodeLits, globalTablePtr->numEntries)); - Tcl_AppendPrintfToObj(objPtr, " Literals reused > 1x\t\t%" TCL_Z_MODIFIER "u\n", + Tcl_AppendPrintfToObj(objPtr, " Literals reused > 1x\t\t%" SIZEu "\n", numSharedMultX); Tcl_AppendPrintfToObj(objPtr, " Mean reference count\t\t%.2f\n", ((double) refCountSum) / globalTablePtr->numEntries); @@ -9792,7 +10411,7 @@ EvalStatsCmd( Tcl_AppendPrintfToObj(objPtr, " String sharing savings \t%.6g = unshared %.6g - shared %.6g\n", (strBytesIfUnshared - statsPtr->currentLitStringBytes), strBytesIfUnshared, statsPtr->currentLitStringBytes); - Tcl_AppendPrintfToObj(objPtr, " Literal mgmt overhead\t\t%" TCL_Z_MODIFIER "u (%0.1f%% of bytes with sharing)\n", + Tcl_AppendPrintfToObj(objPtr, " Literal mgmt overhead\t\t%" SIZEu " (%0.1f%% of bytes with sharing)\n", literalMgmtBytes, Percent(literalMgmtBytes, currentLiteralBytes)); Tcl_AppendPrintfToObj(objPtr, " table %lu + buckets %lu + entries %lu\n", @@ -9851,9 +10470,9 @@ EvalStatsCmd( } sum = 0; for (ui = 0; ui <= maxSizeDecade; ui++) { - decadeHigh = (1 << (ui+1)) - 1; + decadeHigh = (1 << (ui + 1)) - 1; sum += statsPtr->literalCount[ui]; - Tcl_AppendPrintfToObj(objPtr, "\t%10" TCL_SIZE_MODIFIER "d\t\t%8.0f%%\n", + Tcl_AppendPrintfToObj(objPtr, "\t%10" SIZEu "\t\t%8.0f%%\n", decadeHigh, Percent(sum, statsPtr->numLiteralsCreated)); } @@ -9884,9 +10503,9 @@ EvalStatsCmd( maxSizeDecade = i; sum = 0; for (ui = minSizeDecade; ui <= maxSizeDecade; ui++) { - decadeHigh = (1 << (ui+1)) - 1; + decadeHigh = (1 << (ui + 1)) - 1; sum += statsPtr->srcCount[ui]; - Tcl_AppendPrintfToObj(objPtr, "\t%10" TCL_SIZE_MODIFIER "d\t\t%8.0f%%\n", + Tcl_AppendPrintfToObj(objPtr, "\t%10" SIZEu "\t\t%8.0f%%\n", decadeHigh, Percent(sum, statsPtr->numCompilations)); } @@ -9908,9 +10527,9 @@ EvalStatsCmd( maxSizeDecade = i; sum = 0; for (ui = minSizeDecade; ui <= maxSizeDecade; ui++) { - decadeHigh = (1 << (ui+1)) - 1; + decadeHigh = (1 << (ui + 1)) - 1; sum += statsPtr->byteCodeCount[ui]; - Tcl_AppendPrintfToObj(objPtr, "\t%10" TCL_SIZE_MODIFIER "d\t\t%8.0f%%\n", + Tcl_AppendPrintfToObj(objPtr, "\t%10" SIZEu "\t\t%8.0f%%\n", decadeHigh, Percent(sum, statsPtr->numCompilations)); } @@ -9932,7 +10551,7 @@ EvalStatsCmd( maxSizeDecade = i; sum = 0; for (ui = minSizeDecade; ui <= maxSizeDecade; ui++) { - decadeHigh = (1 << (ui+1)) - 1; + decadeHigh = (1 << (ui + 1)) - 1; sum += statsPtr->lifetimeCount[ui]; Tcl_AppendPrintfToObj(objPtr, "\t%12.3f\t\t%8.0f%%\n", decadeHigh/1000.0, Percent(sum, statsPtr->numByteCodesFreed)); @@ -9944,7 +10563,7 @@ EvalStatsCmd( Tcl_AppendPrintfToObj(objPtr, "\nInstruction counts:\n"); for (i = 0; i < LAST_INST_OPCODE; i++) { - Tcl_AppendPrintfToObj(objPtr, "%20s %8" TCL_Z_MODIFIER "u ", + Tcl_AppendPrintfToObj(objPtr, "%20s %8" SIZEu " ", tclInstructionTable[i].name, statsPtr->instructionCount[i]); if (statsPtr->instructionCount[i]) { Tcl_AppendPrintfToObj(objPtr, "%6.1f%%\n", diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index 44959b9..f305391 100644 --- a/generic/tclFCmd.c +++ b/generic/tclFCmd.c @@ -29,6 +29,34 @@ static int FileForceOption(Tcl_Interp *interp, /* *--------------------------------------------------------------------------- * + * CheckFilenameEncodable + * + * This checks if a filename can be encoded on the target platform, + * disallowing things like naked surrogates, etc. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * May update the interpreter result with an error message on failure. + * + *--------------------------------------------------------------------------- + */ +static inline int +CheckFilenameEncodable( + Tcl_Interp *interp, + Tcl_Obj *fileName) +{ + Tcl_DString ds; + int code = Tcl_UtfToExternalDStringEx(interp, TCLFSENCODING, + TclGetString(fileName), TCL_INDEX_NONE, 0, &ds, NULL); + Tcl_DStringFree(&ds); + return code == TCL_OK ? TCL_OK : TCL_ERROR; +} + +/* + *--------------------------------------------------------------------------- + * * TclFileRenameCmd * * This function implements the "rename" subcommand of the "file" @@ -113,7 +141,6 @@ FileCopyRename( int i, result, force; Tcl_StatBuf statBuf; Tcl_Obj *target; - Tcl_DString ds; i = FileForceOption(interp, objc - 1, objv + 1, &force); if (i < 0) { @@ -135,12 +162,9 @@ FileCopyRename( if (Tcl_FSConvertToPathType(interp, target) != TCL_OK) { return TCL_ERROR; } - if (Tcl_UtfToExternalDStringEx(interp, TCLFSENCODING, TclGetString(target), - TCL_INDEX_NONE, 0, &ds, NULL) != TCL_OK) { - Tcl_DStringFree(&ds); + if (CheckFilenameEncodable(interp, target) != TCL_OK) { return TCL_ERROR; } - Tcl_DStringFree(&ds); result = TCL_OK; @@ -232,7 +256,6 @@ TclFileMakeDirsCmd( Tcl_Obj *split = NULL; Tcl_Obj *target = NULL; Tcl_StatBuf statBuf; - Tcl_DString ds; result = TCL_OK; for (i = 1; i < objc; i++) { @@ -240,13 +263,10 @@ TclFileMakeDirsCmd( result = TCL_ERROR; break; } - if (Tcl_UtfToExternalDStringEx(interp, TCLFSENCODING, TclGetString(objv[i]), - TCL_INDEX_NONE, 0, &ds, NULL) != TCL_OK) { - Tcl_DStringFree(&ds); + if (CheckFilenameEncodable(interp, objv[i]) != TCL_OK) { result = TCL_ERROR; break; } - Tcl_DStringFree(&ds); split = Tcl_FSSplitPath(objv[i], &pobjc); Tcl_IncrRefCount(split); @@ -362,7 +382,6 @@ TclFileDeleteCmd( int i, force, result; Tcl_Obj *errfile; Tcl_Obj *errorBuffer = NULL; - Tcl_DString ds; i = FileForceOption(interp, objc - 1, objv + 1, &force); if (i < 0) { @@ -380,13 +399,10 @@ TclFileDeleteCmd( result = TCL_ERROR; goto done; } - if (Tcl_UtfToExternalDStringEx(interp, TCLFSENCODING, TclGetString(objv[i]), - TCL_INDEX_NONE, 0, &ds, NULL) != TCL_OK) { - Tcl_DStringFree(&ds); + if (CheckFilenameEncodable(interp, objv[i]) != TCL_OK) { result = TCL_ERROR; goto done; } - Tcl_DStringFree(&ds); /* * Call lstat() to get info so can delete symbolic link itself. @@ -506,26 +522,19 @@ CopyRenameOneFile( Tcl_Obj *actualSource=NULL; /* If source is a link, then this is the real * file/directory. */ Tcl_StatBuf sourceStatBuf, targetStatBuf; - Tcl_DString ds; if (Tcl_FSConvertToPathType(interp, source) != TCL_OK) { return TCL_ERROR; } - if (Tcl_UtfToExternalDStringEx(interp, TCLFSENCODING, TclGetString(source), - TCL_INDEX_NONE, 0, &ds, NULL) != TCL_OK) { - Tcl_DStringFree(&ds); + if (CheckFilenameEncodable(interp, source) != TCL_OK) { return TCL_ERROR; } - Tcl_DStringFree(&ds); if (Tcl_FSConvertToPathType(interp, target) != TCL_OK) { return TCL_ERROR; } - if (Tcl_UtfToExternalDStringEx(interp, TCLFSENCODING, TclGetString(target), - TCL_INDEX_NONE, 0, &ds, NULL) != TCL_OK) { - Tcl_DStringFree(&ds); + if (CheckFilenameEncodable(interp, target) != TCL_OK) { return TCL_ERROR; } - Tcl_DStringFree(&ds); errfile = NULL; errorBuffer = NULL; @@ -603,7 +612,7 @@ CopyRenameOneFile( { Tcl_Obj *perm; - int index; + Tcl_Size index; TclNewLiteralStringObj(perm, "u+w"); Tcl_IncrRefCount(perm); @@ -985,7 +994,6 @@ TclFileAttrsCmd( Tcl_Obj *objStrings = NULL; Tcl_Size numObjStrings = TCL_INDEX_NONE; Tcl_Obj *filePtr; - Tcl_DString ds; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "name ?-option value ...?"); @@ -996,12 +1004,9 @@ TclFileAttrsCmd( if (Tcl_FSConvertToPathType(interp, filePtr) != TCL_OK) { return TCL_ERROR; } - if (Tcl_UtfToExternalDStringEx(interp, TCLFSENCODING, TclGetString(filePtr), - TCL_INDEX_NONE, 0, &ds, NULL) != TCL_OK) { - Tcl_DStringFree(&ds); + if (CheckFilenameEncodable(interp, filePtr) != TCL_OK) { return TCL_ERROR; } - Tcl_DStringFree(&ds); objc -= 2; objv += 2; @@ -1204,7 +1209,6 @@ TclFileLinkCmd( { Tcl_Obj *contents; int index; - Tcl_DString ds; if (objc < 2 || objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, "?-linktype? linkname ?target?"); @@ -1247,12 +1251,9 @@ TclFileLinkCmd( if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) { return TCL_ERROR; } - if (Tcl_UtfToExternalDStringEx(interp, TCLFSENCODING, TclGetString(objv[index]), - TCL_INDEX_NONE, 0, &ds, NULL) != TCL_OK) { - Tcl_DStringFree(&ds); + if (CheckFilenameEncodable(interp, objv[index]) != TCL_OK) { return TCL_ERROR; } - Tcl_DStringFree(&ds); /* * Create link from source to target. @@ -1310,12 +1311,9 @@ TclFileLinkCmd( if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) { return TCL_ERROR; } - if (Tcl_UtfToExternalDStringEx(interp, TCLFSENCODING, TclGetString(objv[index]), - TCL_INDEX_NONE, 0, &ds, NULL) != TCL_OK) { - Tcl_DStringFree(&ds); + if (CheckFilenameEncodable(interp, objv[index]) != TCL_OK) { return TCL_ERROR; } - Tcl_DStringFree(&ds); /* * Read link @@ -1367,7 +1365,6 @@ TclFileReadLinkCmd( Tcl_Obj *const objv[]) { Tcl_Obj *contents; - Tcl_DString ds; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "name"); @@ -1377,12 +1374,9 @@ TclFileReadLinkCmd( if (Tcl_FSConvertToPathType(interp, objv[1]) != TCL_OK) { return TCL_ERROR; } - if (Tcl_UtfToExternalDStringEx(interp, TCLFSENCODING, TclGetString(objv[1]), - TCL_INDEX_NONE, 0, &ds, NULL) != TCL_OK) { - Tcl_DStringFree(&ds); + if (CheckFilenameEncodable(interp, objv[1]) != TCL_OK) { return TCL_ERROR; } - Tcl_DStringFree(&ds); contents = Tcl_FSLink(objv[1], NULL, 0); diff --git a/generic/tclHash.c b/generic/tclHash.c index 4db576e..2e70a2e 100644 --- a/generic/tclHash.c +++ b/generic/tclHash.c @@ -55,12 +55,13 @@ static Tcl_HashEntry * AllocStringEntry(Tcl_HashTable *tablePtr, * Function prototypes for static functions in this file: */ -static Tcl_HashEntry * BogusFind(Tcl_HashTable *tablePtr, const char *key); static Tcl_HashEntry * BogusCreate(Tcl_HashTable *tablePtr, const char *key, int *newPtr); static Tcl_HashEntry * CreateHashEntry(Tcl_HashTable *tablePtr, const char *key, int *newPtr); +#ifndef TCL_NO_DEPRECATED static Tcl_HashEntry * FindHashEntry(Tcl_HashTable *tablePtr, const char *key); +#endif static void RebuildTable(Tcl_HashTable *tablePtr); const Tcl_HashKeyType tclArrayHashKeyType = { @@ -170,7 +171,9 @@ Tcl_InitCustomHashTable( tablePtr->downShift = 28; tablePtr->mask = 3; tablePtr->keyType = keyType; +#ifndef TCL_NO_DEPRECATED tablePtr->findProc = FindHashEntry; +#endif tablePtr->createProc = CreateHashEntry; if (typePtr == NULL) { @@ -209,18 +212,20 @@ Tcl_InitCustomHashTable( *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED static Tcl_HashEntry * FindHashEntry( Tcl_HashTable *tablePtr, /* Table in which to lookup entry. */ const char *key) /* Key to use to find matching entry. */ { - return CreateHashEntry(tablePtr, key, NULL); + return tablePtr->createProc(tablePtr, key, TCL_HASH_FIND); } +#endif /* *---------------------------------------------------------------------- * - * CreateHashEntry -- + * Tcl_CreateHashEntry -- * * Given a hash table with string keys, and a string key, find the entry * with a matching key. If there is no matching entry, then create a new @@ -238,6 +243,38 @@ FindHashEntry( *---------------------------------------------------------------------- */ +Tcl_HashEntry * +Tcl_CreateHashEntry( + Tcl_HashTable *tablePtr, /* Table in which to lookup entry. */ + const void *key, /* Key to use to find or create matching + * entry. */ + int *newPtr) /* Store info here telling whether a new entry + * was created. */ +{ + Tcl_HashEntry *entry = (*((tablePtr)->createProc))(tablePtr, (const char *)key, newPtr); + if (!entry) { + Tcl_Panic("%s: Memory overflow", "Tcl_CreateHashEntry"); + } + return entry; +} + +Tcl_HashEntry * +Tcl_DbCreateHashEntry( + Tcl_HashTable *tablePtr, /* Table in which to lookup entry. */ + const void *key, /* Key to use to find or create matching + * entry. */ + int *newPtr, /* Store info here telling whether a new entry + * was created. */ + const char *file, + int line) +{ + Tcl_HashEntry *entry = (*((tablePtr)->createProc))(tablePtr, (const char *)key, newPtr); + if (!entry) { + Tcl_Panic("%s: Memory overflow in file %s:%d", "Tcl_CreateHashEntry", file, line); + } + return entry; +} + static Tcl_HashEntry * CreateHashEntry( Tcl_HashTable *tablePtr, /* Table in which to lookup entry. */ @@ -325,7 +362,7 @@ CreateHashEntry( } } - if (!newPtr || (newPtr == TCL_HASH_FIND)) { + if (newPtr == TCL_HASH_FIND) { /* This is the findProc functionality, so we are done. */ return NULL; } @@ -334,11 +371,16 @@ CreateHashEntry( * Entry not found. Add a new one to the bucket. */ - *newPtr = 1; + if (newPtr) { + *newPtr = 1; + } if (typePtr->allocEntryProc) { hPtr = typePtr->allocEntryProc(tablePtr, (void *) key); } else { - hPtr = (Tcl_HashEntry *)Tcl_Alloc(sizeof(Tcl_HashEntry)); + hPtr = (Tcl_HashEntry *)Tcl_AttemptAlloc(sizeof(Tcl_HashEntry)); + if (!hPtr) { + return NULL; + } hPtr->key.oneWordValue = (char *) key; Tcl_SetHashValue(hPtr, NULL); } @@ -502,7 +544,9 @@ Tcl_DeleteHashTable( * re-initialization. */ - tablePtr->findProc = BogusFind; +#ifndef TCL_NO_DEPRECATED + tablePtr->findProc = FindHashEntry; +#endif tablePtr->createProc = BogusCreate; } @@ -682,10 +726,12 @@ AllocArrayEntry( if (size < sizeof(Tcl_HashEntry)) { size = sizeof(Tcl_HashEntry); } - hPtr = (Tcl_HashEntry *)Tcl_Alloc(size); + hPtr = (Tcl_HashEntry *)Tcl_AttemptAlloc(size); - memcpy(hPtr->key.string, keyPtr, count); - Tcl_SetHashValue(hPtr, NULL); + if (hPtr) { + memcpy(hPtr->key.string, keyPtr, count); + Tcl_SetHashValue(hPtr, NULL); + } return hPtr; } @@ -780,10 +826,12 @@ AllocStringEntry( if (size < sizeof(hPtr->key)) { allocsize = sizeof(hPtr->key); } - hPtr = (Tcl_HashEntry *)Tcl_Alloc(offsetof(Tcl_HashEntry, key) + allocsize); - memset(hPtr, 0, offsetof(Tcl_HashEntry, key) + allocsize); - memcpy(hPtr->key.string, string, size); - Tcl_SetHashValue(hPtr, NULL); + hPtr = (Tcl_HashEntry *)Tcl_AttemptAlloc(offsetof(Tcl_HashEntry, key) + allocsize); + if (hPtr) { + memset(hPtr, 0, offsetof(Tcl_HashEntry, key) + allocsize); + memcpy(hPtr->key.string, string, size); + Tcl_SetHashValue(hPtr, NULL); + } return hPtr; } @@ -881,32 +929,6 @@ TclHashStringKey( /* *---------------------------------------------------------------------- * - * BogusFind -- - * - * This function is invoked when Tcl_FindHashEntry is called on a - * table that has been deleted. - * - * Results: - * If Tcl_Panic returns (which it shouldn't) this function returns NULL. - * - * Side effects: - * Generates a panic. - * - *---------------------------------------------------------------------- - */ - -static Tcl_HashEntry * -BogusFind( - TCL_UNUSED(Tcl_HashTable *), - TCL_UNUSED(const char *)) -{ - Tcl_Panic("called %s on deleted table", "Tcl_FindHashEntry"); - return NULL; -} - -/* - *---------------------------------------------------------------------- - * * BogusCreate -- * * This function is invoked when Tcl_CreateHashEntry is called on a @@ -925,9 +947,10 @@ static Tcl_HashEntry * BogusCreate( TCL_UNUSED(Tcl_HashTable *), TCL_UNUSED(const char *), - TCL_UNUSED(int *)) + int *isNew) { - Tcl_Panic("called %s on deleted table", "Tcl_CreateHashEntry"); + Tcl_Panic("called %s on deleted table", + (isNew != TCL_HASH_FIND)? "Tcl_CreateHashEntry" : "Tcl_FindHashEntry"); return NULL; } diff --git a/generic/tclIO.c b/generic/tclIO.c index c884934..41da07c 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -138,6 +138,12 @@ typedef struct { static Tcl_ThreadDataKey dataKey; /* + * Key for looking up the channel table (a Tcl_HashTable indexed by channel + * name) in the interpreter's associated data table. + */ +#define ASSOC_KEY "tclIO" + +/* * Structure to record a close callback. One such record exists for * each close callback registered for a channel. */ @@ -360,7 +366,7 @@ static const Tcl_ObjType chanObjType = { } while (0) #define BUSY_STATE(st, fl) \ - ((((st)->csPtrR) && ((fl) & TCL_READABLE)) || \ + ((((st)->csPtrR) && ((fl) & TCL_READABLE)) || \ (((st)->csPtrW) && ((fl) & TCL_WRITABLE))) #define MAX_CHANNEL_BUFFER_SIZE (1024*1024) @@ -738,8 +744,10 @@ Tcl_SetStdChannel( tsdPtr->stderrInitialized = init; tsdPtr->stderrChannel = channel; if (channel) { - ENCODING_PROFILE_SET(((Channel *)channel)->state->inputEncodingFlags, TCL_ENCODING_PROFILE_REPLACE); - ENCODING_PROFILE_SET(((Channel *)channel)->state->outputEncodingFlags, TCL_ENCODING_PROFILE_REPLACE); + ENCODING_PROFILE_SET(((Channel *)channel)->state->inputEncodingFlags, + TCL_ENCODING_PROFILE_REPLACE); + ENCODING_PROFILE_SET(((Channel *)channel)->state->outputEncodingFlags, + TCL_ENCODING_PROFILE_REPLACE); } break; } @@ -811,8 +819,10 @@ Tcl_GetStdChannel( tsdPtr->stderrInitialized = -1; tsdPtr->stderrChannel = TclpGetDefaultStdChannel(TCL_STDERR); if (tsdPtr->stderrChannel != NULL) { - ENCODING_PROFILE_SET(((Channel *)tsdPtr->stderrChannel)->state->inputEncodingFlags, TCL_ENCODING_PROFILE_REPLACE); - ENCODING_PROFILE_SET(((Channel *)tsdPtr->stderrChannel)->state->outputEncodingFlags, TCL_ENCODING_PROFILE_REPLACE); + ENCODING_PROFILE_SET(((Channel *)tsdPtr->stderrChannel)->state->inputEncodingFlags, + TCL_ENCODING_PROFILE_REPLACE); + ENCODING_PROFILE_SET(((Channel *)tsdPtr->stderrChannel)->state->outputEncodingFlags, + TCL_ENCODING_PROFILE_REPLACE); tsdPtr->stderrInitialized = 1; Tcl_RegisterChannel(NULL, tsdPtr->stderrChannel); } @@ -932,11 +942,11 @@ GetChannelTable( Tcl_HashTable *hTblPtr; /* Hash table of channels. */ Tcl_Channel stdinChan, stdoutChan, stderrChan; - hTblPtr = (Tcl_HashTable *)Tcl_GetAssocData(interp, "tclIO", NULL); + hTblPtr = (Tcl_HashTable *)Tcl_GetAssocData(interp, ASSOC_KEY, NULL); if (hTblPtr == NULL) { hTblPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(hTblPtr, TCL_STRING_KEYS); - Tcl_SetAssocData(interp, "tclIO", + Tcl_SetAssocData(interp, ASSOC_KEY, (Tcl_InterpDeleteProc *) DeleteChannelTable, hTblPtr); /* @@ -1372,7 +1382,7 @@ DetachChannel( statePtr = chanPtr->state; if (interp != NULL) { - hTblPtr = (Tcl_HashTable *)Tcl_GetAssocData(interp, "tclIO", NULL); + hTblPtr = (Tcl_HashTable *)Tcl_GetAssocData(interp, ASSOC_KEY, NULL); if (hTblPtr == NULL) { return TCL_ERROR; } @@ -1617,10 +1627,12 @@ Tcl_CreateChannel( Tcl_Panic("channel type %s must define close2Proc", typePtr->typeName); } if ((TCL_READABLE & mask) && (NULL == typePtr->inputProc)) { - Tcl_Panic("channel type %s must define inputProc when used for reader channel", typePtr->typeName); + Tcl_Panic("channel type %s must define inputProc when used for reader channel", + typePtr->typeName); } if ((TCL_WRITABLE & mask) && (NULL == typePtr->outputProc)) { - Tcl_Panic("channel type %s must define outputProc when used for writer channel", typePtr->typeName); + Tcl_Panic("channel type %s must define outputProc when used for writer channel", + typePtr->typeName); } if (NULL == typePtr->watchProc) { Tcl_Panic("channel type %s must define watchProc", typePtr->typeName); @@ -2458,7 +2470,7 @@ Tcl_RemoveChannelMode( ResetFlag(statePtr, mode); return TCL_OK; - error: + error: if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "Tcl_RemoveChannelMode error: %s. Channel: \"%s\"", @@ -9423,7 +9435,8 @@ TclCopyChannel( * completed. */ - csPtr = (CopyState *)Tcl_Alloc(offsetof(CopyState, buffer) + 1U + !moveBytes * inStatePtr->bufSize); + csPtr = (CopyState *) + Tcl_Alloc(offsetof(CopyState, buffer) + 1U + !moveBytes * inStatePtr->bufSize); csPtr->bufSize = !moveBytes * inStatePtr->bufSize; csPtr->readPtr = inPtr; csPtr->writePtr = outPtr; @@ -9802,7 +9815,7 @@ CopyData( if (moveBytes) { size = DoRead(inStatePtr->topChanPtr, csPtr->buffer, sizeb, - !GotFlag(inStatePtr, CHANNEL_NONBLOCKING)); + !GotFlag(inStatePtr, CHANNEL_NONBLOCKING)); } else { size = DoReadChars(inStatePtr->topChanPtr, bufObj, sizeb, !GotFlag(inStatePtr, CHANNEL_NONBLOCKING) @@ -10165,8 +10178,7 @@ DoRead( } if (!bufPtr) { - readErr: - + readErr: UpdateInterest(chanPtr); TclChannelRelease((Tcl_Channel)chanPtr); return -1; @@ -10702,7 +10714,7 @@ Tcl_IsChannelRegistered( chanPtr = ((Channel *) chan)->state->bottomChanPtr; statePtr = chanPtr->state; - hTblPtr = (Tcl_HashTable *)Tcl_GetAssocData(interp, "tclIO", NULL); + hTblPtr = (Tcl_HashTable *)Tcl_GetAssocData(interp, ASSOC_KEY, NULL); if (hTblPtr == NULL) { return 0; } diff --git a/generic/tclIO.h b/generic/tclIO.h index 1077e09..7825516 100644 --- a/generic/tclIO.h +++ b/generic/tclIO.h @@ -95,7 +95,7 @@ typedef struct EventScriptRecord { */ typedef struct Channel { - struct ChannelState *state; /* Split out state information */ + struct ChannelState *state; /* Split out state information */ void *instanceData; /* Instance-specific data provided by creator * of channel. */ const Tcl_ChannelType *typePtr; /* Pointer to channel type structure. */ @@ -158,11 +158,6 @@ typedef struct ChannelState { * of line sequences in output? */ int inEofChar; /* If nonzero, use this as a signal of EOF on * input. */ -#if TCL_MAJOR_VERSION < 9 - int outEofChar; /* If nonzero, append this to the channel when - * it is closed if it is open for writing. - * For Tcl 8.x only */ -#endif int unreportedError; /* Non-zero if an error report was deferred * because it happened in the background. The * value is the POSIX error code. */ diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index bd3a462..83b2ab3 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -35,6 +35,13 @@ typedef struct { static Tcl_ThreadDataKey dataKey; /* + * Key for looking up the table of registered TCP accept callbacks, a hash + * table indexed by AcceptCallback references, used as a set (values are + * meaningless). + */ +#define ASSOC_KEY "tclTCPAcceptCallbacks" + +/* * Static functions for this file: */ @@ -369,8 +376,8 @@ Tcl_ReadObjCmd( { Tcl_Channel chan; /* The channel to read from. */ int newline, i; /* Discard newline at end? */ - Tcl_WideInt toRead; /* How many bytes to read? */ - Tcl_Size charactersRead; /* How many characters were read? */ + Tcl_WideInt toRead; /* How many bytes to read? */ + Tcl_Size charactersRead; /* How many characters were read? */ int mode; /* Mode in which channel is opened. */ Tcl_Obj *resultPtr, *chanObjPtr; @@ -1027,7 +1034,7 @@ Tcl_ExecObjCmd( /* TIP 716 */ if (encodingObj && - Tcl_SetChannelOption(interp, chan, "-encoding", + Tcl_SetChannelOption(interp, chan, "-encoding", Tcl_GetString(encodingObj)) != TCL_OK) { goto errorWithOpenChannel; } @@ -1169,7 +1176,7 @@ Tcl_OpenObjCmd( if (objc == 4) { const char *permString = TclGetString(objv[3]); int code = TCL_ERROR; - int scanned = TclParseAllWhiteSpace(permString, -1); + Tcl_Size scanned = TclParseAllWhiteSpace(permString, -1); /* * Support legacy octal numbers. @@ -1272,7 +1279,7 @@ Tcl_OpenObjCmd( static void TcpAcceptCallbacksDeleteProc( - void *clientData, /* Data which was passed when the assocdata + void *clientData, /* Data which was passed when the assocdata * was registered. */ TCL_UNUSED(Tcl_Interp *)) { @@ -1324,12 +1331,12 @@ RegisterTcpServerInterpCleanup( Tcl_HashEntry *hPtr; /* Entry for this record. */ int isNew; /* Is the entry new? */ - hTblPtr = (Tcl_HashTable *)Tcl_GetAssocData(interp, "tclTCPAcceptCallbacks", NULL); + hTblPtr = (Tcl_HashTable *)Tcl_GetAssocData(interp, ASSOC_KEY, NULL); if (hTblPtr == NULL) { hTblPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(hTblPtr, TCL_ONE_WORD_KEYS); - Tcl_SetAssocData(interp, "tclTCPAcceptCallbacks", + Tcl_SetAssocData(interp, ASSOC_KEY, TcpAcceptCallbacksDeleteProc, hTblPtr); } @@ -1370,7 +1377,7 @@ UnregisterTcpServerInterpCleanupProc( Tcl_HashTable *hTblPtr; Tcl_HashEntry *hPtr; - hTblPtr = (Tcl_HashTable *)Tcl_GetAssocData(interp, "tclTCPAcceptCallbacks", NULL); + hTblPtr = (Tcl_HashTable *)Tcl_GetAssocData(interp, ASSOC_KEY, NULL); if (hTblPtr == NULL) { return; } @@ -1400,7 +1407,7 @@ UnregisterTcpServerInterpCleanupProc( static void AcceptCallbackProc( - void *callbackData, /* The data stored when the callback was + void *callbackData, /* The data stored when the callback was * created in the call to * Tcl_OpenTcpServer. */ Tcl_Channel chan, /* Channel for the newly accepted @@ -1491,7 +1498,7 @@ AcceptCallbackProc( static void TcpServerCloseProc( - void *callbackData) /* The data passed in the call to + void *callbackData) /* The data passed in the call to * Tcl_CreateCloseHandler. */ { AcceptCallback *acceptCallbackPtr = (AcceptCallback *)callbackData; diff --git a/generic/tclIOGT.c b/generic/tclIOGT.c index 9b5ef87..15ee36c 100644 --- a/generic/tclIOGT.c +++ b/generic/tclIOGT.c @@ -56,7 +56,7 @@ typedef struct TransformChannelData TransformChannelData; static int ExecuteCallback(TransformChannelData *ctrl, Tcl_Interp *interp, unsigned char *op, - unsigned char *buf, int bufLen, int transmit, + unsigned char *buf, Tcl_Size bufLen, int transmit, int preserve); /* @@ -267,8 +267,8 @@ TclChannelTransform( } if (TCL_OK != TclListObjLength(interp, cmdObjPtr, &objc)) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("-command value is not a list", -1)); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "-command value is not a list", -1)); return TCL_ERROR; } @@ -366,7 +366,7 @@ ExecuteCallback( Tcl_Interp *interp, /* Current interpreter, possibly NULL. */ unsigned char *op, /* Operation invoking the callback. */ unsigned char *buf, /* Buffer to give to the script. */ - int bufLen, /* And its length. */ + Tcl_Size bufLen, /* And its length. */ int transmit, /* Flag, determines whether the result of the * callback is sent to the underlying channel * or not. */ @@ -515,7 +515,7 @@ ExecuteCallback( static int TransformBlockModeProc( - void *instanceData, /* State of transformation. */ + void *instanceData, /* State of transformation. */ int mode) /* New blocking mode. */ { TransformChannelData *dataPtr = (TransformChannelData *)instanceData; @@ -637,7 +637,8 @@ TransformInputProc( int *errorCodePtr) { TransformChannelData *dataPtr = (TransformChannelData *)instanceData; - int gotBytes, read, copied; + int gotBytes, copied; + Tcl_Size read; Tcl_Channel downChan; /* @@ -1013,7 +1014,7 @@ TransformGetOptionProc( static void TransformWatchProc( - void *instanceData, /* Channel to watch. */ + void *instanceData, /* Channel to watch. */ int mask) /* Events of interest. */ { TransformChannelData *dataPtr = (TransformChannelData *)instanceData; @@ -1091,9 +1092,9 @@ TransformWatchProc( static int TransformGetFileHandleProc( - void *instanceData, /* Channel to query. */ + void *instanceData, /* Channel to query. */ int direction, /* Direction of interest. */ - void **handlePtr) /* Place to store the handle into. */ + void **handlePtr) /* Place to store the handle into. */ { TransformChannelData *dataPtr = (TransformChannelData *)instanceData; @@ -1125,7 +1126,7 @@ TransformGetFileHandleProc( static int TransformNotifyProc( - void *clientData, /* The state of the notified + void *clientData, /* The state of the notified * transformation. */ int mask) /* The mask of occurring events. */ { @@ -1170,7 +1171,7 @@ TransformNotifyProc( static void TransformChannelHandlerTimer( - void *clientData) /* Transformation to query. */ + void *clientData) /* Transformation to query. */ { TransformChannelData *dataPtr = (TransformChannelData *)clientData; diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c index d2d9d7a..6b981a1 100644 --- a/generic/tclIORChan.c +++ b/generic/tclIORChan.c @@ -162,7 +162,7 @@ typedef enum { static const char *const methodNames[] = { "blocking", /* OPT */ "cget", /* OPT \/ Together or none */ - "cgetall", /* OPT /\ of these two */ + "cgetall", /* OPT /\ of these two. */ "configure", /* OPT */ "finalize", /* */ "initialize", /* */ @@ -461,8 +461,9 @@ static const char *msg_seek_beforestart = "{Tried to seek before origin}"; #if TCL_THREADS static const char *msg_send_originlost = "{Channel thread lost}"; #endif /* TCL_THREADS */ -static const char *msg_send_dstlost = "{Owner lost}"; -static const char *msg_dstlost = "-code 1 -level 0 -errorcode NONE -errorinfo {} -errorline 1 {Owner lost}"; +static const char *msg_send_dstlost = "{Owner lost}"; +static const char *msg_dstlost = + "-code 1 -level 0 -errorcode NONE -errorinfo {} -errorline 1 {Owner lost}"; /* * Main methods to plug into the 'chan' ensemble'. ================== @@ -722,7 +723,7 @@ TclChanCreateObjCmd( #if TCL_THREADS rcmPtr = GetThreadReflectedChannelMap(); hPtr = Tcl_CreateHashEntry(&rcmPtr->map, chanPtr->state->channelName, - &isNew); + NULL); Tcl_SetHashValue(hPtr, chan); #endif @@ -913,8 +914,8 @@ TclChanPostEventObjCmd( return TCL_ERROR; } if (events == 0) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("bad event list: is empty", -1)); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "bad event list: is empty", -1)); return TCL_ERROR; } @@ -1350,14 +1351,14 @@ ReflectInput( memcpy(buf, bytev, bytec); } - stop: + stop: Tcl_DecrRefCount(toReadObj); Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */ Tcl_Release(rcPtr); return bytec; - invalid: + invalid: *errorCodePtr = EINVAL; - error: + error: bytec = -1; goto stop; } @@ -1478,15 +1479,15 @@ ReflectOutput( } *errorCodePtr = EOK; - stop: + stop: Tcl_DecrRefCount(bufObj); Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */ Tcl_Release(rcPtr->interp); Tcl_Release(rcPtr); return written; - invalid: + invalid: *errorCodePtr = EINVAL; - error: + error: written = -1; goto stop; } @@ -1571,13 +1572,13 @@ ReflectSeekWide( } *errorCodePtr = EOK; - stop: + stop: Tcl_DecrRefCount(offObj); Tcl_DecrRefCount(baseObj); Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */ Tcl_Release(rcPtr); return newLoc; - invalid: + invalid: *errorCodePtr = EINVAL; newLoc = -1; goto stop; @@ -1778,7 +1779,7 @@ ReflectThread( static int ReflectSetOption( - void *clientData, /* Channel to query */ + void *clientData, /* Channel to query */ Tcl_Interp *interp, /* Interpreter to leave error messages in */ const char *optionName, /* Name of requested option */ const char *newValue) /* The new value */ @@ -1850,7 +1851,7 @@ ReflectSetOption( static int ReflectGetOption( - void *clientData, /* Channel to query */ + void *clientData, /* Channel to query */ Tcl_Interp *interp, /* Interpreter to leave error messages in */ const char *optionName, /* Name of reuqested option */ Tcl_DString *dsPtr) /* String to place the result into */ @@ -1971,16 +1972,16 @@ ReflectGetOption( goto ok; } - ok: + ok: result = TCL_OK; - stop: + stop: if (optionObj) { Tcl_DecrRefCount(optionObj); } Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */ Tcl_Release(rcPtr); return result; - error: + error: result = TCL_ERROR; goto stop; } @@ -2003,7 +2004,7 @@ ReflectGetOption( static int ReflectTruncate( - void *clientData, /* Channel to query */ + void *clientData, /* Channel to query */ long long length) /* Length to truncate to. */ { ReflectedChannel *rcPtr = (ReflectedChannel *)clientData; @@ -2086,7 +2087,7 @@ EncodeEventMask( int *mask) { int events; /* Mask of events to post */ - Tcl_Size listc; /* #elements in eventspec list */ + Tcl_Size listc; /* #elements in eventspec list */ Tcl_Obj **listv; /* Elements of eventspec list */ int evIndex; /* Id of event for an element of the eventspec * list. */ @@ -2565,13 +2566,13 @@ MarkDead( static void DeleteReflectedChannelMap( - void *clientData, /* The per-interpreter data structure. */ + void *clientData, /* The per-interpreter data structure. */ Tcl_Interp *interp) /* The interpreter being deleted. */ { ReflectedChannelMap *rcmPtr = (ReflectedChannelMap *)clientData; /* The map */ - Tcl_HashSearch hSearch; /* Search variable. */ - Tcl_HashEntry *hPtr; /* Search variable. */ + Tcl_HashSearch hSearch; /* Search variable. */ + Tcl_HashEntry *hPtr; /* Search variable. */ ReflectedChannel *rcPtr; Tcl_Channel chan; #if TCL_THREADS diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c index 16c357f..eba5af5 100644 --- a/generic/tclIORTrans.c +++ b/generic/tclIORTrans.c @@ -695,7 +695,7 @@ TclChanPushObjCmd( Tcl_SetHashValue(hPtr, rtPtr); #if TCL_THREADS rtmPtr = GetThreadReflectedTransformMap(); - hPtr = Tcl_CreateHashEntry(&rtmPtr->map, TclGetString(rtId), &isNew); + hPtr = Tcl_CreateHashEntry(&rtmPtr->map, TclGetString(rtId), NULL); Tcl_SetHashValue(hPtr, rtPtr); #endif /* TCL_THREADS */ @@ -1211,7 +1211,7 @@ ReflectInput( Tcl_SetByteArrayLength(bufObj, 0); } /* while toRead > 0 */ - stop: + stop: if (gotBytes == 0) { rtPtr->eofPending = 0; } @@ -1219,7 +1219,7 @@ ReflectInput( Tcl_Release(rtPtr); return gotBytes; - error: + error: gotBytes = -1; goto stop; } @@ -2106,8 +2106,8 @@ DeleteReflectedTransformMap( Tcl_Interp *interp) /* The interpreter being deleted. */ { ReflectedTransformMap *rtmPtr; /* The map */ - Tcl_HashSearch hSearch; /* Search variable. */ - Tcl_HashEntry *hPtr; /* Search variable. */ + Tcl_HashSearch hSearch; /* Search variable. */ + Tcl_HashEntry *hPtr; /* Search variable. */ ReflectedTransform *rtPtr; #if TCL_THREADS ForwardingResult *resultPtr; @@ -2268,8 +2268,8 @@ static void DeleteThreadReflectedTransformMap( TCL_UNUSED(void *)) { - Tcl_HashSearch hSearch; /* Search variable. */ - Tcl_HashEntry *hPtr; /* Search variable. */ + Tcl_HashSearch hSearch; /* Search variable. */ + Tcl_HashEntry *hPtr; /* Search variable. */ Tcl_ThreadId self = Tcl_GetCurrentThread(); ReflectedTransformMap *rtmPtr; /* The map */ ForwardingResult *resultPtr; diff --git a/generic/tclIOSock.c b/generic/tclIOSock.c index 511f2a2..bdac0b6 100644 --- a/generic/tclIOSock.c +++ b/generic/tclIOSock.c @@ -336,6 +336,25 @@ Tcl_OpenTcpServer( -1, acceptProc, callbackData); } +#ifdef TCL_SOCK_PRINTF_DEBUGGING +/* printf debugging */ +void +printaddrinfo( + struct addrinfo *addrlist, + char *prefix) +{ + char host[NI_MAXHOST], port[NI_MAXSERV]; + struct addrinfo *ai; + + for (ai = addrlist; ai != NULL; ai = ai->ai_next) { + getnameinfo(ai->ai_addr, ai->ai_addrlen, + host, sizeof(host), port, sizeof(port), + NI_NUMERICHOST|NI_NUMERICSERV); + fprintf(stderr,"%s: %s:%s\n", prefix, host, port); + } +} +#endif + /* * Local Variables: * mode: c diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 124485c..aa3e8d0 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -208,8 +208,8 @@ TCL_DECLARE_MUTEX(filesystemMutex) * A files-system indepent sense of the current directory. */ -static Tcl_Obj *cwdPathPtr = NULL; -static size_t cwdPathEpoch = 0; /* The pathname of the current directory */ +static Tcl_Obj *cwdPathPtr = NULL; /* The pathname of the current directory */ +static size_t cwdPathEpoch = 0; static void *cwdClientData = NULL; TCL_DECLARE_MUTEX(cwdMutex) @@ -255,8 +255,7 @@ Tcl_Stat( Tcl_WideInt tmp1, tmp2, tmp3 = 0; # define OUT_OF_RANGE(x) \ - (((Tcl_WideInt)(x)) < LONG_MIN || \ - ((Tcl_WideInt)(x)) > LONG_MAX) + (((Tcl_WideInt)(x)) < LONG_MIN || ((Tcl_WideInt)(x)) > LONG_MAX) # define OUT_OF_URANGE(x) \ (((Tcl_WideUInt)(x)) > ((Tcl_WideUInt)ULONG_MAX)) @@ -1323,8 +1322,8 @@ TclFSNormalizeToUniquePath( int startAt) /* Offset the string of pathPtr to start at. * Must either be 0 or offset of a directory * separator at the end of a pathname part that - * is already normalized, I.e. not the index of - * the byte just after the separator. */ + * is already normalized, i.e. not the index of + * the byte just after the separator. */ { FilesystemRecord *fsRecPtr, *firstFsRecPtr; @@ -2447,7 +2446,7 @@ int TclFSFileAttrIndex( Tcl_Obj *pathPtr, /* Pathname of the file. */ const char *attributeName, /* The name of the attribute. */ - int *indexPtr) /* A place to store the result. */ + Tcl_Size *indexPtr) /* A place to store the result. */ { Tcl_Obj *listObj = NULL; const char *const *attrTable; @@ -2912,7 +2911,7 @@ Tcl_FSChdir( if (retVal == 0) { /* Assume that the cwd was actually changed to the normalized value - * just calculated, and cache that information. */ + * just calculated, and cache that information. */ /* * If the filesystem epoch changed recently, the normalized pathname or @@ -3096,7 +3095,7 @@ Tcl_FSLoadFile( #endif static int -skipUnlink( +SkipUnlink( Tcl_Obj *shlibFile) { /* @@ -3313,7 +3312,7 @@ Tcl_LoadFile( */ { - int index; + Tcl_Size index; Tcl_Obj *perm; TclNewLiteralStringObj(perm, "0o700"); @@ -3347,7 +3346,7 @@ Tcl_LoadFile( * and it avoids leaving the copy laying around after exit. */ - if (!skipUnlink(copyToPtr) && + if (!SkipUnlink(copyToPtr) && (Tcl_FSDeleteFile(copyToPtr) == TCL_OK)) { Tcl_DecrRefCount(copyToPtr); @@ -3379,7 +3378,7 @@ Tcl_LoadFile( tvdlPtr->unloadProcPtr = newUnloadProcPtr; if (copyFsPtr != &tclNativeFilesystem) { - /* refCount of copyToPtr is already incremented. */ + /* refCount of copyToPtr is already incremented. */ tvdlPtr->divertedFile = copyToPtr; /* @@ -4343,7 +4342,7 @@ Tcl_FSRemoveDirectory( Tcl_Obj *pathPtr, /* The pathname of the directory to be removed. */ int recursive, /* If zero, removes only an empty directory. * Otherwise, removes the directory and all its - * contents. */ + * contents. */ Tcl_Obj **errorPtr) /* If not NULL and an error occurs, stores a * place to store a pointer to a new * object having a refCount of 1 and containing @@ -4462,7 +4461,7 @@ Tcl_FSGetFileSystemForPath( /* This is the filesystem for pathPtr. Assume the type of pathPtr * hasn't been changed by the above call to the * pathInFilesystemProc, and cache this result in the internal - * representation of pathPtr. */ + * representation of pathPtr. */ TclFSSetPathDetails(pathPtr, fsRecPtr->fsPtr, clientData); Disclaim(); diff --git a/generic/tclIcu.c b/generic/tclIcu.c index a375d62..0f73875 100644 --- a/generic/tclIcu.c +++ b/generic/tclIcu.c @@ -45,9 +45,9 @@ typedef enum { } UConverterCallbackReasonx; typedef enum UNormalizationCheckResultx { - UNORM_NO, - UNORM_YES, - UNORM_MAYBE + UNORM_NO, + UNORM_YES, + UNORM_MAYBE } UNormalizationCheckResultx; typedef struct UEnumeration UEnumeration; @@ -59,50 +59,31 @@ typedef struct UConverter UConverter; typedef struct UConverterFromUnicodeArgs UConverterFromUnicodeArgs; typedef struct UConverterToUnicodeArgs UConverterToUnicodeArgs; typedef void (*UConverterFromUCallback)(const void *context, - UConverterFromUnicodeArgs *args, - const UCharx *codeUnits, - int32_t length, UChar32x codePoint, - UConverterCallbackReasonx reason, - UErrorCodex *pErrorCode); + UConverterFromUnicodeArgs *args, const UCharx *codeUnits, + int32_t length, UChar32x codePoint, UConverterCallbackReasonx reason, + UErrorCodex *pErrorCode); typedef void (*UConverterToUCallback)(const void *context, - UConverterToUnicodeArgs *args, - const char *codeUnits, - int32_t length, - UConverterCallbackReasonx reason, - UErrorCodex *pErrorCode); + UConverterToUnicodeArgs *args, const char *codeUnits, + int32_t length, UConverterCallbackReasonx reason, + UErrorCodex *pErrorCode); /* * Prototypes for ICU functions sorted by category. */ typedef void (*fn_u_cleanup)(void); typedef const char *(*fn_u_errorName)(UErrorCodex); -typedef UCharx *(*fn_u_strFromUTF32)(UCharx *dest, - int32_t destCapacity, - int32_t *pDestLength, - const UChar32x *src, - int32_t srcLength, - UErrorCodex *pErrorCode); -typedef UCharx *(*fn_u_strFromUTF32WithSub)(UCharx *dest, - int32_t destCapacity, - int32_t *pDestLength, - const UChar32x *src, - int32_t srcLength, - UChar32x subchar, - int32_t *pNumSubstitutions, - UErrorCodex *pErrorCode); -typedef UChar32x *(*fn_u_strToUTF32)(UChar32x *dest, - int32_t destCapacity, - int32_t *pDestLength, - const UCharx *src, - int32_t srcLength, - UErrorCodex *pErrorCode); +typedef UCharx *(*fn_u_strFromUTF32)(UCharx *dest, int32_t destCapacity, + int32_t *pDestLength, const UChar32x *src, int32_t srcLength, + UErrorCodex *pErrorCode); +typedef UCharx *(*fn_u_strFromUTF32WithSub)(UCharx *dest, int32_t destCapacity, + int32_t *pDestLength, const UChar32x *src, int32_t srcLength, + UChar32x subchar, int32_t *pNumSubstitutions, UErrorCodex *pErrorCode); +typedef UChar32x *(*fn_u_strToUTF32)(UChar32x *dest, int32_t destCapacity, + int32_t *pDestLength, const UCharx *src, int32_t srcLength, + UErrorCodex *pErrorCode); typedef UChar32x *(*fn_u_strToUTF32WithSub)(UChar32x *dest, - int32_t destCapacity, - int32_t *pDestLength, - const UCharx *src, - int32_t srcLength, - UChar32x subchar, - int32_t *pNumSubstitutions, - UErrorCodex *pErrorCode); + int32_t destCapacity, int32_t *pDestLength, const UCharx *src, + int32_t srcLength, UChar32x subchar, int32_t *pNumSubstitutions, + UErrorCodex *pErrorCode); typedef void (*fn_ucnv_close)(UConverter *); typedef uint16_t (*fn_ucnv_countAliases)(const char *, UErrorCodex *); @@ -113,19 +94,15 @@ typedef const char *(*fn_ucnv_getAlias)(const char *, uint16_t, UErrorCodex *); typedef const char *(*fn_ucnv_getAvailableName)(int32_t); typedef UConverter *(*fn_ucnv_open)(const char *converterName, UErrorCodex *); typedef void (*fn_ucnv_setFromUCallBack)(UConverter *, - UConverterFromUCallback newAction, - const void *newContext, - UConverterFromUCallback *oldAction, - const void **oldContext, - UErrorCodex *err); + UConverterFromUCallback newAction, const void *newContext, + UConverterFromUCallback *oldAction, const void **oldContext, + UErrorCodex *err); typedef void (*fn_ucnv_setToUCallBack)(UConverter *, - UConverterToUCallback newAction, - const void *newContext, - UConverterToUCallback *oldAction, - const void **oldContext, - UErrorCodex *err); + UConverterToUCallback newAction, const void *newContext, + UConverterToUCallback *oldAction, const void **oldContext, + UErrorCodex *err); typedef int32_t (*fn_ucnv_toUChars)(UConverter *, UCharx *dest, - int32_t destCapacity, const char *src, int32_t srcLen, UErrorCodex *); + int32_t destCapacity, const char *src, int32_t srcLen, UErrorCodex *); typedef UConverterFromUCallback fn_UCNV_FROM_U_CALLBACK_STOP; typedef UConverterToUCallback fn_UCNV_TO_U_CALLBACK_STOP; @@ -161,12 +138,8 @@ typedef UNormalizer2 *(*fn_unorm2_getNFCInstance)(UErrorCodex *); typedef UNormalizer2 *(*fn_unorm2_getNFDInstance)(UErrorCodex *); typedef UNormalizer2 *(*fn_unorm2_getNFKCInstance)(UErrorCodex *); typedef UNormalizer2 *(*fn_unorm2_getNFKDInstance)(UErrorCodex *); -typedef int32_t (*fn_unorm2_normalize)(const UNormalizer2 *, - const UCharx *, - int32_t, - UCharx *, - int32_t, - UErrorCodex *); +typedef int32_t (*fn_unorm2_normalize)(const UNormalizer2 *, const UCharx *, + int32_t, UCharx *, int32_t, UErrorCodex *); #define FIELD(name) fn_ ## name _ ## name @@ -354,8 +327,8 @@ DetectEncoding( return TCL_ERROR; } if (len > INT_MAX) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("Max length supported by ICU exceeded.", TCL_INDEX_NONE)); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "Max length supported by ICU exceeded.", TCL_INDEX_NONE)); return TCL_ERROR; } UErrorCodex status = U_ZERO_ERRORZ; @@ -499,14 +472,9 @@ IcuObjToUCharDString( char *s; Tcl_Size len; s = Tcl_GetStringFromObj(objPtr, &len); - result = Tcl_UtfToExternalDStringEx(interp, - encoding, - s, - len, - strict ? TCL_ENCODING_PROFILE_STRICT - : TCL_ENCODING_PROFILE_REPLACE, - dsPtr, - NULL); + result = Tcl_UtfToExternalDStringEx(interp, encoding, s, len, + strict ? TCL_ENCODING_PROFILE_STRICT : TCL_ENCODING_PROFILE_REPLACE, + dsPtr, NULL); if (result != TCL_OK) { Tcl_DStringFree(dsPtr); /* Must be done on error */ /* TCL_CONVER_* errors -> TCL_ERROR */ @@ -554,14 +522,9 @@ IcuObjFromUCharDString( Tcl_Size len = Tcl_DStringLength(dsPtr); Tcl_DString dsOut; int result; - result = Tcl_ExternalToUtfDStringEx(interp, - encoding, - s, - len, - strict ? TCL_ENCODING_PROFILE_STRICT - : TCL_ENCODING_PROFILE_REPLACE, - &dsOut, - NULL); + result = Tcl_ExternalToUtfDStringEx(interp, encoding, s, len, + strict ? TCL_ENCODING_PROFILE_STRICT : TCL_ENCODING_PROFILE_REPLACE, + &dsOut, NULL); if (result == TCL_OK) { objPtr = Tcl_DStringToObj(&dsOut); /* Clears dsPtr! */ @@ -776,8 +739,8 @@ IcuConverttoDString( Tcl_Size utf16len = Tcl_DStringLength(dsInPtr) / sizeof(UCharx); Tcl_Size dstLen, dstCapacity; if (utf16len > INT_MAX) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("Max length supported by ICU exceeded.", TCL_INDEX_NONE)); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "Max length supported by ICU exceeded.", TCL_INDEX_NONE)); return TCL_ERROR; } @@ -840,8 +803,8 @@ IcuBytesToUCharDString( } if (nbytes > INT_MAX) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("Max length supported by ICU exceeded.", TCL_INDEX_NONE)); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "Max length supported by ICU exceeded.", TCL_INDEX_NONE)); return TCL_ERROR; } @@ -864,7 +827,7 @@ IcuBytesToUCharDString( Tcl_DStringInit(dsOutPtr); Tcl_DStringSetLength(dsOutPtr, dstCapacity); dstLen = ucnv_toUChars(ucnvPtr, (UCharx *)Tcl_DStringValue(dsOutPtr), dstCapacity, - (const char *)bytes, (int)nbytes, &status); + (const char *)bytes, (int)nbytes, &status); if (U_FAILURE(status)) { switch (status) { case U_STRING_NOT_TERMINATED_WARNING: @@ -874,7 +837,7 @@ IcuBytesToUCharDString( Tcl_DStringSetLength(dsOutPtr, dstCapacity); status = U_ZERO_ERRORZ; /* Reset before call */ dstLen = ucnv_toUChars(ucnvPtr, (UCharx *)Tcl_DStringValue(dsOutPtr), dstCapacity, - (const char *)bytes, (int)nbytes, &status); + (const char *)bytes, (int)nbytes, &status); if (U_SUCCESS(status)) { break; } @@ -949,8 +912,8 @@ IcuNormalizeUCharDString( utf16 = (UCharx *) Tcl_DStringValue(dsInPtr); utf16len = Tcl_DStringLength(dsInPtr) / sizeof(UCharx); if (utf16len > INT_MAX) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("Max length supported by ICU exceeded.", TCL_INDEX_NONE)); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "Max length supported by ICU exceeded.", TCL_INDEX_NONE)); return TCL_ERROR; } Tcl_DStringInit(dsOutPtr); @@ -1014,9 +977,9 @@ static int IcuParseConvertOptions( } ++i; if (i == objc) { - Tcl_SetObjResult(interp, - Tcl_ObjPrintf("Missing value for option %s.", - Tcl_GetString(objv[i - 1]))); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "Missing value for option %s.", + Tcl_GetString(objv[i - 1]))); return TCL_ERROR; } const char *s = Tcl_GetString(objv[i]); @@ -1025,17 +988,17 @@ static int IcuParseConvertOptions( if (!strcmp(s, "replace")) { strict = 0; } else if (strcmp(s, "strict")) { - Tcl_SetObjResult(interp, - Tcl_ObjPrintf("Invalid value \"%s\" supplied for option" - " \"-profile\". Must be \"strict\" or \"replace\".", - s)); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "Invalid value \"%s\" supplied for option" + " \"-profile\". Must be \"strict\" or \"replace\".", + s)); return TCL_ERROR; } break; case OPT_FAILINDEX: /* TBD */ - Tcl_SetObjResult(interp, - Tcl_NewStringObj("Option -failindex not implemented.", TCL_INDEX_NONE)); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "Option -failindex not implemented.", TCL_INDEX_NONE)); return TCL_ERROR; default: TCL_UNREACHABLE(); @@ -1184,9 +1147,9 @@ IcuNormalizeObjCmd( } ++i; if (i == (objc-1)) { - Tcl_SetObjResult(interp, - Tcl_ObjPrintf("Missing value for option %s.", - Tcl_GetString(objv[i - 1]))); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "Missing value for option %s.", + Tcl_GetString(objv[i - 1]))); return TCL_ERROR; } const char *s = Tcl_GetString(objv[i]); @@ -1195,15 +1158,16 @@ IcuNormalizeObjCmd( if (!strcmp(s, "replace")) { strict = 0; } else if (strcmp(s, "strict")) { - Tcl_SetObjResult(interp, - Tcl_ObjPrintf("Invalid value \"%s\" supplied for option \"-profile\". Must be " - "\"strict\" or \"replace\".", - s)); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "Invalid value \"%s\" supplied for option \"-profile\". " + "Must be \"strict\" or \"replace\".", + s)); return TCL_ERROR; } break; case OPT_MODE: - if (Tcl_GetIndexFromObj(interp, objv[i], normalizationForms, "normalization mode", 0, &mode) != TCL_OK) { + if (Tcl_GetIndexFromObj(interp, objv[i], normalizationForms, + "normalization mode", 0, &mode) != TCL_OK) { return TCL_ERROR; } break; @@ -1443,10 +1407,10 @@ TclIcuInit( /* Symbol may have version (Linux), or not (Windows, FreeBSD) */ -#define ICUUC_SYM(name) \ - do { \ - icu_fns._##name = \ - (fn_##name)IcuFindSymbol(icu_fns.libs[0], #name, icuversion); \ +#define ICUUC_SYM(name) \ + do { \ + icu_fns._##name = (fn_##name) \ + IcuFindSymbol(icu_fns.libs[0], #name, icuversion); \ } while (0) if (icu_fns.libs[0] != NULL) { @@ -1490,10 +1454,10 @@ TclIcuInit( #undef ICUUC_SYM } -#define ICUIN_SYM(name) \ - do { \ - icu_fns._##name = \ - (fn_##name)IcuFindSymbol(icu_fns.libs[1], #name, icuversion); \ +#define ICUIN_SYM(name) \ + do { \ + icu_fns._##name = (fn_##name) \ + IcuFindSymbol(icu_fns.libs[1], #name, icuversion); \ } while (0) if (icu_fns.libs[1] != NULL) { @@ -1519,9 +1483,9 @@ TclIcuInit( /* Ref count number of commands */ icu_fns.nopen += 3; Tcl_CreateObjCommand(interp, "::tcl::unsupported::icu::convertto", - IcuConverttoObjCmd, 0, TclIcuCleanup); + IcuConverttoObjCmd, 0, TclIcuCleanup); Tcl_CreateObjCommand(interp, "::tcl::unsupported::icu::convertfrom", - IcuConvertfromObjCmd, 0, TclIcuCleanup); + IcuConvertfromObjCmd, 0, TclIcuCleanup); Tcl_CreateObjCommand(interp, "::tcl::unsupported::icu::detect", IcuDetectObjCmd, 0, TclIcuCleanup); } diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index 2c2bd35..710babb 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -55,7 +55,7 @@ const Tcl_ObjType tclIndexType = { typedef struct { void *tablePtr; /* Pointer to the table of strings */ - Tcl_Size offset; /* Offset between table entries */ + Tcl_Size offset; /* Offset between table entries */ Tcl_Size index; /* Selected index into table. */ } IndexRep; @@ -68,7 +68,9 @@ typedef struct { #define NEXT_ENTRY(table, offset) \ (&(STRING_AT(table, offset))) #define EXPAND_OF(indexRep) \ - (((indexRep)->index != TCL_INDEX_NONE) ? STRING_AT((indexRep)->tablePtr, (indexRep)->offset*(indexRep)->index) : "") + (((indexRep)->index != TCL_INDEX_NONE) ? \ + STRING_AT((indexRep)->tablePtr, (indexRep)->offset*(indexRep)->index) : \ + "") /* *---------------------------------------------------------------------- @@ -303,20 +305,20 @@ Tcl_GetIndexFromObjStruct( flags &= (30-(int)(sizeof(int)<<1)); if (flags) { if (flags == sizeof(uint16_t)<<1) { - *(uint16_t *)indexPtr = index; + *(uint16_t *)indexPtr = (uint16_t)index; return TCL_OK; } else if (flags == (int)(sizeof(uint8_t)<<1)) { - *(uint8_t *)indexPtr = index; + *(uint8_t *)indexPtr = (uint8_t)index; return TCL_OK; } else if (flags == (int)(sizeof(int64_t)<<1)) { *(int64_t *)indexPtr = index; return TCL_OK; } else if (flags == (int)(sizeof(int32_t)<<1)) { - *(int32_t *)indexPtr = index; + *(int32_t *)indexPtr = (int32_t)index; return TCL_OK; } } - *(int *)indexPtr = index; + *(int *)indexPtr = (int)index; } return TCL_OK; @@ -363,7 +365,8 @@ Tcl_GetIndexFromObjStruct( } /* #define again, needed below */ #define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \ - ((Tcl_GetIndexFromObjStruct)((interp), (objPtr), (tablePtr), (offset), (msg), (flags)|(int)(sizeof(*(indexPtr))<<1), (indexPtr))) + ((Tcl_GetIndexFromObjStruct)((interp), (objPtr), (tablePtr), (offset), \ + (msg), (flags)|(int)(sizeof(*(indexPtr))<<1), (indexPtr))) /* *---------------------------------------------------------------------- @@ -386,7 +389,8 @@ static void UpdateStringOfIndex( Tcl_Obj *objPtr) { - IndexRep *indexRep = (IndexRep *)TclFetchInternalRep(objPtr, &tclIndexType)->twoPtrValue.ptr1; + IndexRep *indexRep = (IndexRep *) + TclFetchInternalRep(objPtr, &tclIndexType)->twoPtrValue.ptr1; const char *indexStr = EXPAND_OF(indexRep); size_t len = strlen(indexStr); @@ -807,7 +811,7 @@ PrefixLongestObjCmd( void Tcl_WrongNumArgs( Tcl_Interp *interp, /* Current interpreter. */ - Tcl_Size objc, /* Number of arguments to print from objv. */ + Tcl_Size objc, /* Number of arguments to print from objv. */ Tcl_Obj *const objv[], /* Initial argument objects, which should be * included in the error message. */ const char *message) /* Error message to print after the leading @@ -1010,13 +1014,13 @@ Tcl_ParseArgsObjv( /* Descriptor that matches current argument */ Tcl_Obj *curArg; /* Current argument */ const char *str = NULL; - char c; /* Second character of current arg (used for + char c; /* Second character of current arg (used for * quick check for matching; use 2nd char. * because first char. will almost always be * '-'). */ - Tcl_Size srcIndex; /* Location from which to read next argument + Tcl_Size srcIndex; /* Location from which to read next argument * from objv. */ - Tcl_Size dstIndex; /* Used to keep track of current arguments + Tcl_Size dstIndex; /* Used to keep track of current arguments * being processed, primarily for error * reporting. */ Tcl_Size objc; /* # arguments in objv still to process. */ @@ -1108,7 +1112,7 @@ Tcl_ParseArgsObjv( infoPtr = matchPtr; switch (infoPtr->type) { case TCL_ARGV_CONSTANT: - *((int *) infoPtr->dstPtr) = PTR2INT(infoPtr->srcPtr); + *((int *)infoPtr->dstPtr) = (int)PTR2INT(infoPtr->srcPtr); break; case TCL_ARGV_INT: if (objc == 0) { @@ -1140,7 +1144,7 @@ Tcl_ParseArgsObjv( */ if (infoPtr->dstPtr != NULL) { - *((int *) infoPtr->dstPtr) = dstIndex; + *((int *)infoPtr->dstPtr) = (int)dstIndex; } goto argsDone; case TCL_ARGV_FLOAT: @@ -1148,7 +1152,7 @@ Tcl_ParseArgsObjv( goto missingArg; } if (Tcl_GetDoubleFromObj(interp, objv[srcIndex], - (double *) infoPtr->dstPtr) == TCL_ERROR) { + (double *)infoPtr->dstPtr) == TCL_ERROR) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "expected floating-point argument for \"%s\" but got \"%s\"", infoPtr->keyStr, TclGetString(objv[srcIndex]))); @@ -1269,7 +1273,7 @@ PrintUsage( * descriptions. */ { const Tcl_ArgvInfo *infoPtr; - int width, numSpaces; + Tcl_Size width, numSpaces; #define NUM_SPACES 20 static const char spaces[] = " "; Tcl_Obj *msg; diff --git a/generic/tclInt.decls b/generic/tclInt.decls index e0abf48..1fd54b9 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -158,17 +158,12 @@ declare 61 { declare 62 { int TclObjCommandComplete(Tcl_Obj *cmdPtr) } -# Removed in 9.0: -#declare 63 { -# int TclObjInterpProc(void *clientData, Tcl_Interp *interp, -# Tcl_Size objc, Tcl_Obj *const objv[]) -#} declare 64 { int TclObjInvoke(Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[], int flags) } declare 69 { - void *TclpAlloc(TCL_HASH_TYPE size) + void *TclpAlloc(size_t size) } declare 74 { void TclpFree(void *ptr) @@ -184,7 +179,7 @@ declare 76 { # void TclpGetTime(Tcl_Time *time) #} declare 81 { - void *TclpRealloc(void *ptr, TCL_HASH_TYPE size) + void *TclpRealloc(void *ptr, size_t size) } # Removed in 9.0: #declare 88 { @@ -465,7 +460,7 @@ declare 214 { void TclSetObjNameOfExecutable(Tcl_Obj *name, Tcl_Encoding encoding) } declare 215 { - void *TclStackAlloc(Tcl_Interp *interp, TCL_HASH_TYPE numBytes) + void *TclStackAlloc(Tcl_Interp *interp, size_t numBytes) } declare 216 { void TclStackFree(Tcl_Interp *interp, void *freePtr) diff --git a/generic/tclInt.h b/generic/tclInt.h index c450c80..9252eb8 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -244,10 +244,8 @@ typedef struct NamespacePathEntry NamespacePathEntry; typedef struct TclVarHashTable { Tcl_HashTable table; /* "Inherit" from Tcl_HashTable. */ struct Namespace *nsPtr; /* The namespace containing the variables. */ -#if TCL_MAJOR_VERSION > 8 struct Var *arrayPtr; /* The array containing the variables, if they * are variables in an array at all. */ -#endif /* TCL_MAJOR_VERSION > 8 */ } TclVarHashTable; /* @@ -290,11 +288,7 @@ typedef struct Namespace { * strings; values have type (Namespace *). If * NULL, there are no children. */ #endif -#if TCL_MAJOR_VERSION > 8 size_t nsId; /* Unique id for the namespace. */ -#else - unsigned long nsId; -#endif Tcl_Interp *interp; /* The interpreter containing this * namespace. */ int flags; /* OR-ed combination of the namespace status @@ -995,9 +989,6 @@ typedef struct CompiledLocal { * Among others used to speed up var lookups. */ Tcl_Size frameIndex; /* Index in the array of compiler-assigned * variables in the procedure call frame. */ -#if TCL_MAJOR_VERSION < 9 - int flags; -#endif Tcl_Obj *defValuePtr; /* Pointer to the default value of an * argument, if any. NULL if not an argument * or, if an argument, no default value. */ @@ -1008,12 +999,10 @@ typedef struct CompiledLocal { * is marked by a unique tag during * compilation, and that same tag is used to * find the variable at runtime. */ -#if TCL_MAJOR_VERSION > 8 int flags; /* Flag bits for the local variable. Same as * the flags for the Var structure above, * although only VAR_ARGUMENT, VAR_TEMPORARY, * and VAR_RESOLVED make sense. */ -#endif char name[TCLFLEXARRAY]; /* Name of the local variable starts here. If * the name is NULL, this will just be '\0'. * The actual size of this field will be large @@ -1071,11 +1060,7 @@ typedef void (ProcErrorProc)(Tcl_Interp *interp, Tcl_Obj *procNameObj); typedef struct Trace { Tcl_Size level; /* Only trace commands at nesting level less * than or equal to this. */ -#if TCL_MAJOR_VERSION > 8 Tcl_CmdObjTraceProc2 *proc; /* Procedure to call to trace command. */ -#else - Tcl_CmdObjTraceProc *proc; /* Procedure to call to trace command. */ -#endif void *clientData; /* Arbitrary value to pass to proc. */ struct Trace *nextPtr; /* Next in list of traces for this interp. */ int flags; /* Flags governing the trace - see @@ -1119,7 +1104,6 @@ typedef struct ActiveInterpTrace { #define TCL_TRACE_ENTER_EXEC 1 #define TCL_TRACE_LEAVE_EXEC 2 -#if TCL_MAJOR_VERSION > 8 #define TclObjTypeHasProc(objPtr, proc) (((objPtr)->typePtr \ && ((offsetof(Tcl_ObjType, proc) < offsetof(Tcl_ObjType, version)) \ || (offsetof(Tcl_ObjType, proc) < (objPtr)->typePtr->version))) ? \ @@ -1221,7 +1205,6 @@ TclObjTypeInOperator( Tcl_ObjTypeInOperatorProc *proc = TclObjTypeHasProc(listObj, inOperProc); return proc(interp, valueObj, listObj, boolResult); } -#endif /* TCL_MAJOR_VERSION > 8 */ /* * The structure below defines an entry in the assocData hash table which is @@ -1365,7 +1348,7 @@ typedef struct CmdFrame { int type; /* Values see below. */ int level; /* Number of frames in stack, prevent O(n) * scan of list. */ - Tcl_Size *line; /* Lines the words of the command start on. */ + int *line; /* Lines the words of the command start on. */ Tcl_Size nline; /* Number of lines in CmdFrame.line. */ CallFrame *framePtr; /* Procedure activation record, may be * NULL. */ @@ -1676,6 +1659,10 @@ typedef struct ExecEnv { #define COR_IS_SUSPENDED(corPtr) \ ((corPtr)->stackLevel == NULL) +// The different types of yielded coroutine we have. +#define CORO_ACTIVATE_YIELD NULL // 0 or 1 argument expected +#define CORO_ACTIVATE_YIELDM INT2PTR(1) // Arbitrary arguments expected + /* * The definitions for the LiteralTable and LiteralEntry structures. Each * interpreter contains a LiteralTable. It is used to reduce the storage @@ -1716,13 +1703,13 @@ typedef struct LiteralTable { LiteralEntry *staticBuckets[TCL_SMALL_HASH_TABLE]; /* Bucket array used for small tables to avoid * mallocs and frees. */ - TCL_HASH_TYPE numBuckets; /* Total number of buckets allocated at + size_t numBuckets; /* Total number of buckets allocated at * **buckets. */ - TCL_HASH_TYPE numEntries; /* Total number of entries present in + size_t numEntries; /* Total number of entries present in * table. */ - TCL_HASH_TYPE rebuildSize; /* Enlarge table when numEntries gets to be + size_t rebuildSize; /* Enlarge table when numEntries gets to be * this large. */ - TCL_HASH_TYPE mask; /* Mask value used in hashing function. */ + size_t mask; /* Mask value used in hashing function. */ } LiteralTable; /* @@ -1875,35 +1862,39 @@ typedef struct Command { /* * Flag bits for commands. - * - * CMD_DYING - If 1 the command is in the process of - * being deleted (its deleteProc is currently - * executing). Other attempts to delete the - * command should be ignored. - * CMD_TRACE_ACTIVE - If 1 the trace processing is currently - * underway for a rename/delete change. See the - * two flags below for which is currently being - * processed. - * CMD_HAS_EXEC_TRACES - If 1 means that this command has at least one - * execution trace (as opposed to simple - * delete/rename traces) in its tracePtr list. - * CMD_COMPILES_EXPANDED - If 1 this command has a compiler that - * can handle expansion (provided it is not the - * first word). - * TCL_TRACE_RENAME - A rename trace is in progress. Further - * recursive renames will not be traced. - * TCL_TRACE_DELETE - A delete trace is in progress. Further - * recursive deletes will not be traced. - * (these last two flags are defined in tcl.h) - */ - -#define CMD_DYING 0x01 -#define CMD_TRACE_ACTIVE 0x02 -#define CMD_HAS_EXEC_TRACES 0x04 -#define CMD_COMPILES_EXPANDED 0x08 -#define CMD_REDEF_IN_PROGRESS 0x10 -#define CMD_VIA_RESOLVER 0x20 -#define CMD_DEAD 0x40 + */ +enum CommandFlags { + CMD_DYING = 0x01, /* The command is in the process of being + * deleted (its deleteProc is currently + * executing). Other attempts to delete the + * command should be ignored.*/ + CMD_TRACE_ACTIVE = 0x02, /* The trace processing is currently underway + * for a rename/delete change. See the flags + * CMD_TRACE_RENAMING, CMD_TRACE_DELETING for + * which is currently being processed. */ + CMD_HAS_EXEC_TRACES = 0x04, /* This command has at least one execution + * trace (as opposed to simple delete/rename + * traces) in its tracePtr list. */ + CMD_COMPILES_EXPANDED = 0x08, + /* This command has a compiler that can handle + * expansion (provided it is not the first + * word). */ + CMD_REDEF_IN_PROGRESS = 0x10, + /* Command is currently being redefined. It + * should not be deleted, though its ClientData + * may be purged. */ + CMD_VIA_RESOLVER = 0x20, /* Command was located by resolver. Its literal + * should be marked unshared by the compiler. */ + CMD_DEAD = 0x40, /* Command is at an advanced stage of being + * deleted, and is no longer in any hash tables + * but stale references may exist elsewhere. */ + CMD_TRACE_RENAMING = TCL_TRACE_RENAME, + /* A rename trace is in progress. Further + * recursive renames will not be traced. */ + CMD_TRACE_DELETING = TCL_TRACE_DELETE + /* A delete trace is in progress. Further + * recursive deletes will not be traced. */ +}; /* *---------------------------------------------------------------- @@ -2016,20 +2007,9 @@ typedef struct Interp { void *interpInfo; /* Information used by tclInterp.c to keep * track of parent/child interps on a * per-interp basis. */ -#if TCL_MAJOR_VERSION > 8 void (*optimizer)(void *envPtr); /* Reference to the bytecode optimizer, if one * is set. */ -#else - union { - void (*optimizer)(void *envPtr); - Tcl_HashTable unused2; /* No longer used (was mathFuncTable). The - * unused space in interp was repurposed for - * pluggable bytecode optimizers. The core - * contains one optimizer, which can be - * selectively overridden by extensions. */ - } extra; -#endif /* * Information related to procedures and variables. See tclProc.c and * tclVar.c for usage. @@ -2058,11 +2038,6 @@ typedef struct Interp { Namespace *lookupNsPtr; /* Namespace to use ONLY on the next * TCL_EVAL_INVOKE call to Tcl_EvalObjv. */ -#if TCL_MAJOR_VERSION < 9 - char *appendResultDontUse; - int appendAvlDontUse; - int appendUsedDontUse; -#endif /* * Information about packages. Used only in tclPkg.c. @@ -2086,9 +2061,6 @@ typedef struct Interp { * Normally zero, but may be set before * calling Tcl_Eval. See below for valid * values. */ -#if TCL_MAJOR_VERSION < 9 - int unused1; /* No longer used (was termOffset) */ -#endif LiteralTable literalTable; /* Contains LiteralEntry's describing all Tcl * objects holding literals of scripts * compiled by the interpreter. Indexed by the @@ -2125,9 +2097,6 @@ typedef struct Interp { * string. Returned by Tcl_ObjSetVar2 when * variable traces change a variable in a * gross way. */ -#if TCL_MAJOR_VERSION < 9 - char resultSpaceDontUse[TCL_DSTRING_STATIC_SIZE+1]; -#endif Tcl_Obj *objResultPtr; /* If the last command returned an object * result, this points to it. Should not be * accessed directly; see comment above. */ @@ -2235,7 +2204,7 @@ typedef struct Interp { * invoking context of the bytecode compiler. * NULL when the byte code compiler is not * active. */ - int invokeWord; /* Index of the word in the command which + Tcl_Size invokeWord; /* Index of the word in the command which * is getting compiled. */ Tcl_HashTable *linePBodyPtr;/* This table remembers for each statically * defined procedure the location information @@ -2495,7 +2464,7 @@ typedef struct Interp { #if defined(__APPLE__) #define TCL_ALLOCALIGN 16 #else -#define TCL_ALLOCALIGN (2*sizeof(void *)) +#define TCL_ALLOCALIGN (2*(int)sizeof(void *)) #endif /* @@ -2612,10 +2581,11 @@ typedef struct ListStore { Tcl_Obj *slots[TCLFLEXARRAY]; /* Variable size array. Grown as needed */ } ListStore; - -#define LISTSTORE_CANONICAL 0x1 /* All Tcl_Obj's referencing this +enum ListStoreFlags { + LISTSTORE_CANONICAL = 1 /* All Tcl_Obj's referencing this * store have their string representation * derived from the list representation */ +}; /* Max number of elements that can be contained in a list */ #define LIST_MAX \ @@ -2791,20 +2761,11 @@ typedef struct ListRep { * WARNING: these macros eval their args more than once. */ -#if TCL_MAJOR_VERSION > 8 #define TclGetBooleanFromObj(interp, objPtr, intPtr) \ ((TclHasInternalRep((objPtr), &tclIntType) \ || TclHasInternalRep((objPtr), &tclBooleanType)) \ ? (*(intPtr) = ((objPtr)->internalRep.wideValue!=0), TCL_OK) \ : Tcl_GetBooleanFromObj((interp), (objPtr), (intPtr))) -#else -#define TclGetBooleanFromObj(interp, objPtr, intPtr) \ - ((TclHasInternalRep((objPtr), &tclIntType)) \ - ? (*(intPtr) = ((objPtr)->internalRep.wideValue!=0), TCL_OK) \ - : (TclHasInternalRep((objPtr), &tclBooleanType)) \ - ? (*(intPtr) = ((objPtr)->internalRep.longValue!=0), TCL_OK) \ - : Tcl_GetBooleanFromObj((interp), (objPtr), (intPtr))) -#endif #ifdef TCL_WIDE_INT_IS_LONG #define TclGetLongFromObj(interp, objPtr, longPtr) \ @@ -2942,7 +2903,7 @@ typedef Tcl_Channel (TclOpenFileChannelProc_)(Tcl_Interp *interp, */ typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, - TCL_HASH_TYPE *lengthPtr, + size_t *lengthPtr, Tcl_Encoding *encodingPtr); #ifdef _WIN32 @@ -2964,7 +2925,7 @@ typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, typedef struct ProcessGlobalValue { Tcl_Size epoch; /* Epoch counter to detect changes in the * global value. */ - TCL_HASH_TYPE numBytes; /* Length of the global string. */ + size_t numBytes; /* Length of the global string. */ char *value; /* The global string value. */ Tcl_Encoding encoding; /* system encoding when global string was * initialized. */ @@ -3143,16 +3104,7 @@ MODULE_SCOPE int TclEncodingProfileNameToId(Tcl_Interp *interp, MODULE_SCOPE const char *TclEncodingProfileIdToName(Tcl_Interp *interp, int profileId); MODULE_SCOPE void TclGetEncodingProfiles(Tcl_Interp *interp); -/* TIP 716 - MODULE_SCOPE for 9.0.2. Will be public in 9.1 */ -#ifdef _WIN32 -MODULE_SCOPE const char *Tcl_GetEncodingNameForUser(Tcl_DString *bufPtr); -#else -static inline const char * -Tcl_GetEncodingNameForUser(Tcl_DString *bufPtr) -{ - return Tcl_GetEncodingNameFromEnvironment(bufPtr); -} -#endif + /* * TIP #233 (Virtualized Time) * Data for the time hooks, if any. @@ -3237,6 +3189,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRSubstObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRSwitchObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRTryObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRUplevelObjCmd; +MODULE_SCOPE Tcl_NRPostProc TclUplevelCallback; MODULE_SCOPE Tcl_ObjCmdProc TclNRWhileObjCmd; MODULE_SCOPE Tcl_NRPostProc TclNRForIterCallback; @@ -3248,6 +3201,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldmObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldToObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRInvoke; +MODULE_SCOPE Tcl_NRPostProc TclNRPostInvoke; MODULE_SCOPE Tcl_NRPostProc TclNRReleaseValues; MODULE_SCOPE void TclSetTailcall(Tcl_Interp *interp, @@ -3308,15 +3262,25 @@ struct Tcl_LoadHandle_ { /* Mask to isolate the conversion type */ /* + * Clock operations, communicated from command definitions to the bytecode + * compiler. + */ +enum ClockOps { + CLOCK_READ_CLICKS = 0, /* Read the click counter. */ + CLOCK_READ_MICROS = 1, /* Time in microseconds. */ + CLOCK_READ_MILLIS = 2, /* Time in milliseconds. */ + CLOCK_READ_SECS = 3 /* Time in seconds. */ +}; + +/* *---------------------------------------------------------------- * Procedures shared among Tcl modules but not used by the outside world: *---------------------------------------------------------------- */ -#if TCL_MAJOR_VERSION > 8 -MODULE_SCOPE void TclAdvanceContinuations(Tcl_Size *line, Tcl_Size **next, - int loc); -MODULE_SCOPE void TclAdvanceLines(Tcl_Size *line, const char *start, +MODULE_SCOPE void TclAdvanceContinuations(int *line, Tcl_Size **next, + Tcl_Size loc); +MODULE_SCOPE void TclAdvanceLines(int *line, const char *start, const char *end); MODULE_SCOPE int TclAliasCreate(Tcl_Interp *interp, Tcl_Interp *childInterp, Tcl_Interp *parentInterp, @@ -3350,7 +3314,7 @@ MODULE_SCOPE void TclChannelPreserve(Tcl_Channel chan); MODULE_SCOPE void TclChannelRelease(Tcl_Channel chan); MODULE_SCOPE int TclChannelGetBlockingMode(Tcl_Channel chan); MODULE_SCOPE int TclCheckArrayTraces(Tcl_Interp *interp, Var *varPtr, - Var *arrayPtr, Tcl_Obj *name, int index); + Var *arrayPtr, Tcl_Obj *name, Tcl_Size index); MODULE_SCOPE int TclCheckEmptyString(Tcl_Obj *objPtr); MODULE_SCOPE int TclChanCaughtErrorBypass(Tcl_Interp *interp, Tcl_Channel chan); @@ -3393,7 +3357,7 @@ MODULE_SCOPE int TclDictRemove(Tcl_Interp *interp, Tcl_Obj *dictPtr, const char *key); /* TIP #280 - Modified token based evaluation, with line information. */ MODULE_SCOPE int TclEvalEx(Tcl_Interp *interp, const char *script, - Tcl_Size numBytes, int flags, Tcl_Size line, + Tcl_Size numBytes, int flags, int line, Tcl_Size *clNextOuter, const char *outerScript); MODULE_SCOPE Tcl_ObjCmdProc TclFileAttrsCmd; MODULE_SCOPE Tcl_ObjCmdProc TclFileCopyCmd; @@ -3445,7 +3409,7 @@ MODULE_SCOPE void TclFinalizeThreadObjects(void); MODULE_SCOPE double TclFloor(const void *a); MODULE_SCOPE void TclFormatNaN(double value, char *buffer); MODULE_SCOPE int TclFSFileAttrIndex(Tcl_Obj *pathPtr, - const char *attributeName, int *indexPtr); + const char *attributeName, Tcl_Size *indexPtr); MODULE_SCOPE Tcl_Command TclNRCreateCommandInNs(Tcl_Interp *interp, const char *cmdName, Tcl_Namespace *nsPtr, Tcl_ObjCmdProc *proc, Tcl_ObjCmdProc *nreProc, @@ -3513,8 +3477,8 @@ MODULE_SCOPE Tcl_Obj * TclLindexFlat(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Size indexCount, Tcl_Obj *const indexArray[]); MODULE_SCOPE Tcl_Obj * TclListObjGetElement(Tcl_Obj *listObj, Tcl_Size index); /* TIP #280 */ -MODULE_SCOPE void TclListLines(Tcl_Obj *listObj, Tcl_Size line, Tcl_Size n, - Tcl_Size *lines, Tcl_Obj *const *elems); +MODULE_SCOPE void TclListLines(Tcl_Obj *listObj, int line, Tcl_Size n, + int *lines, Tcl_Obj *const *elems); MODULE_SCOPE Tcl_Obj * TclListObjCopy(Tcl_Interp *interp, Tcl_Obj *listPtr); MODULE_SCOPE int TclListObjAppendElements(Tcl_Interp *interp, Tcl_Obj *toObj, Tcl_Size elemCount, @@ -3530,7 +3494,7 @@ MODULE_SCOPE Tcl_Command TclMakeEnsemble(Tcl_Interp *interp, const char *name, const EnsembleImplMap map[]); MODULE_SCOPE Tcl_Size TclMaxListLength(const char *bytes, Tcl_Size numBytes, const char **endPtr); -MODULE_SCOPE int TclMergeReturnOptions(Tcl_Interp *interp, int objc, +MODULE_SCOPE int TclMergeReturnOptions(Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[], Tcl_Obj **optionsPtrPtr, int *codePtr, int *levelPtr); MODULE_SCOPE Tcl_Obj * TclNoErrorStack(Tcl_Interp *interp, Tcl_Obj *options); @@ -3539,13 +3503,13 @@ MODULE_SCOPE void TclNsDecrRefCount(Namespace *nsPtr); MODULE_SCOPE int TclNamespaceDeleted(Namespace *nsPtr); MODULE_SCOPE void TclObjVarErrMsg(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const char *operation, - const char *reason, int index); + const char *reason, Tcl_Size index); MODULE_SCOPE int TclObjInvokeNamespace(Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[], Tcl_Namespace *nsPtr, int flags); MODULE_SCOPE int TclObjUnsetVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags); -MODULE_SCOPE int TclParseBackslash(const char *src, +MODULE_SCOPE Tcl_Size TclParseBackslash(const char *src, Tcl_Size numBytes, Tcl_Size *readPtr, char *dst); MODULE_SCOPE int TclParseNumber(Tcl_Interp *interp, Tcl_Obj *objPtr, const char *expected, const char *bytes, @@ -3592,10 +3556,10 @@ MODULE_SCOPE int TclCreateSocketAddress(Tcl_Interp *interp, const char **errorMsgPtr); MODULE_SCOPE int TclpThreadCreate(Tcl_ThreadId *idPtr, Tcl_ThreadCreateProc *proc, void *clientData, - TCL_HASH_TYPE stackSize, int flags); + size_t stackSize, int flags); MODULE_SCOPE Tcl_Size TclpFindVariable(const char *name, Tcl_Size *lengthPtr); MODULE_SCOPE void TclpInitLibraryPath(char **valuePtr, - TCL_HASH_TYPE *lengthPtr, Tcl_Encoding *encodingPtr); + size_t *lengthPtr, Tcl_Encoding *encodingPtr); MODULE_SCOPE void TclpInitLock(void); MODULE_SCOPE void * TclpInitNotifier(void); MODULE_SCOPE void TclpInitPlatform(void); @@ -3659,7 +3623,7 @@ MODULE_SCOPE void TclSpellFix(Tcl_Interp *interp, Tcl_Obj *const *objv, Tcl_Size objc, Tcl_Size subIdx, Tcl_Obj *bad, Tcl_Obj *fix); MODULE_SCOPE void * TclStackRealloc(Tcl_Interp *interp, void *ptr, - TCL_HASH_TYPE numBytes); + size_t numBytes); typedef int (*memCmpFn_t)(const void*, const void*, size_t); MODULE_SCOPE int TclStringCmp(Tcl_Obj *value1Ptr, Tcl_Obj *value2Ptr, int checkEq, int nocase, Tcl_Size reqlength); @@ -3668,7 +3632,7 @@ MODULE_SCOPE int TclStringMatch(const char *str, Tcl_Size strLen, MODULE_SCOPE int TclStringMatchObj(Tcl_Obj *stringObj, Tcl_Obj *patternObj, int flags); MODULE_SCOPE void TclSubstCompile(Tcl_Interp *interp, const char *bytes, - Tcl_Size numBytes, int flags, Tcl_Size line, + Tcl_Size numBytes, int flags, int line, struct CompileEnv *envPtr); MODULE_SCOPE int TclSubstOptions(Tcl_Interp *interp, Tcl_Size numOpts, Tcl_Obj *const opts[], int *flagPtr); @@ -3676,7 +3640,7 @@ MODULE_SCOPE void TclSubstParse(Tcl_Interp *interp, const char *bytes, Tcl_Size numBytes, int flags, Tcl_Parse *parsePtr, Tcl_InterpState *statePtr); MODULE_SCOPE int TclSubstTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr, - Tcl_Size count, int *tokensLeftPtr, Tcl_Size line, + Tcl_Size count, Tcl_Size *tokensLeftPtr, int line, Tcl_Size *clNextOuter, const char *outerScript); MODULE_SCOPE Tcl_Size TclTrim(const char *bytes, Tcl_Size numBytes, const char *trim, Tcl_Size numTrim, @@ -3737,7 +3701,7 @@ MODULE_SCOPE void TclErrorStackResetIf(Tcl_Interp *interp, MODULE_SCOPE int TclZipfs_Init(Tcl_Interp *interp); MODULE_SCOPE int TclIsZipfsPath(const char *path); MODULE_SCOPE void TclZipfsFinalize(void); -MODULE_SCOPE int TclZipfsLocateTclLibrary(void); +MODULE_SCOPE int TclZipfsLocateTclLibrary(void); /* * Many parsing tasks need a common definition of whitespace. @@ -3781,7 +3745,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclDefaultBgErrorHandlerObjCmd; MODULE_SCOPE Tcl_Command TclInitDictCmd(Tcl_Interp *interp); MODULE_SCOPE int TclDictWithFinish(Tcl_Interp *interp, Var *varPtr, Var *arrayPtr, Tcl_Obj *part1Ptr, - Tcl_Obj *part2Ptr, int index, int pathc, + Tcl_Obj *part2Ptr, Tcl_Size index, Tcl_Size pathc, Tcl_Obj *const pathv[], Tcl_Obj *keysPtr); MODULE_SCOPE Tcl_Obj * TclDictWithInit(Tcl_Interp *interp, Tcl_Obj *dictPtr, Tcl_Size pathc, Tcl_Obj *const pathv[]); @@ -3899,6 +3863,8 @@ MODULE_SCOPE CompileProc TclCompileDictIncrCmd; MODULE_SCOPE CompileProc TclCompileDictLappendCmd; MODULE_SCOPE CompileProc TclCompileDictMapCmd; MODULE_SCOPE CompileProc TclCompileDictMergeCmd; +MODULE_SCOPE CompileProc TclCompileDictRemoveCmd; +MODULE_SCOPE CompileProc TclCompileDictReplaceCmd; MODULE_SCOPE CompileProc TclCompileDictSetCmd; MODULE_SCOPE CompileProc TclCompileDictUnsetCmd; MODULE_SCOPE CompileProc TclCompileDictUpdateCmd; @@ -3916,18 +3882,22 @@ MODULE_SCOPE CompileProc TclCompileInfoCoroutineCmd; MODULE_SCOPE CompileProc TclCompileInfoExistsCmd; MODULE_SCOPE CompileProc TclCompileInfoLevelCmd; MODULE_SCOPE CompileProc TclCompileInfoObjectClassCmd; +MODULE_SCOPE CompileProc TclCompileInfoObjectCreationIdCmd; MODULE_SCOPE CompileProc TclCompileInfoObjectIsACmd; MODULE_SCOPE CompileProc TclCompileInfoObjectNamespaceCmd; MODULE_SCOPE CompileProc TclCompileIncrCmd; MODULE_SCOPE CompileProc TclCompileLappendCmd; MODULE_SCOPE CompileProc TclCompileLassignCmd; +MODULE_SCOPE CompileProc TclCompileLeditCmd; MODULE_SCOPE CompileProc TclCompileLindexCmd; MODULE_SCOPE CompileProc TclCompileLinsertCmd; MODULE_SCOPE CompileProc TclCompileListCmd; MODULE_SCOPE CompileProc TclCompileLlengthCmd; MODULE_SCOPE CompileProc TclCompileLmapCmd; +MODULE_SCOPE CompileProc TclCompileLpopCmd; MODULE_SCOPE CompileProc TclCompileLrangeCmd; MODULE_SCOPE CompileProc TclCompileLreplaceCmd; +MODULE_SCOPE CompileProc TclCompileLseqCmd; MODULE_SCOPE CompileProc TclCompileLsetCmd; MODULE_SCOPE CompileProc TclCompileNamespaceCodeCmd; MODULE_SCOPE CompileProc TclCompileNamespaceCurrentCmd; @@ -3969,6 +3939,7 @@ MODULE_SCOPE CompileProc TclCompileTailcallCmd; MODULE_SCOPE CompileProc TclCompileThrowCmd; MODULE_SCOPE CompileProc TclCompileTryCmd; MODULE_SCOPE CompileProc TclCompileUnsetCmd; +MODULE_SCOPE CompileProc TclCompileUplevelCmd; MODULE_SCOPE CompileProc TclCompileUpvarCmd; MODULE_SCOPE CompileProc TclCompileVariableCmd; MODULE_SCOPE CompileProc TclCompileWhileCmd; @@ -4073,25 +4044,25 @@ MODULE_SCOPE Var * TclLookupArrayElement(Tcl_Interp *interp, Tcl_Obj *arrayNamePtr, Tcl_Obj *elNamePtr, int flags, const char *msg, int createPart1, int createPart2, - Var *arrayPtr, int index); + Var *arrayPtr, Tcl_Size index); MODULE_SCOPE Tcl_Obj * TclPtrGetVarIdx(Tcl_Interp *interp, Var *varPtr, Var *arrayPtr, Tcl_Obj *part1Ptr, - Tcl_Obj *part2Ptr, int flags, int index); + Tcl_Obj *part2Ptr, int flags, Tcl_Size index); MODULE_SCOPE Tcl_Obj * TclPtrSetVarIdx(Tcl_Interp *interp, Var *varPtr, Var *arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, - int flags, int index); + int flags, Tcl_Size index); MODULE_SCOPE Tcl_Obj * TclPtrIncrObjVarIdx(Tcl_Interp *interp, Var *varPtr, Var *arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, - int flags, int index); + int flags, Tcl_Size index); MODULE_SCOPE int TclPtrObjMakeUpvarIdx(Tcl_Interp *interp, Var *otherPtr, Tcl_Obj *myNamePtr, int myFlags, - int index); + Tcl_Size index); MODULE_SCOPE int TclPtrUnsetVarIdx(Tcl_Interp *interp, Var *varPtr, Var *arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags, - int index); + Tcl_Size index); MODULE_SCOPE void TclInvalidateNsPath(Namespace *nsPtr); MODULE_SCOPE void TclFindArrayPtrElements(Var *arrayPtr, Tcl_HashTable *tablePtr); @@ -4102,7 +4073,7 @@ MODULE_SCOPE void TclFindArrayPtrElements(Var *arrayPtr, MODULE_SCOPE int TclObjCallVarTraces(Interp *iPtr, Var *arrayPtr, Var *varPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, - int flags, int leaveErrMsg, int index); + int flags, int leaveErrMsg, Tcl_Size index); /* * So tclObj.c and tclDictObj.c can share these implementations. @@ -4110,7 +4081,7 @@ MODULE_SCOPE int TclObjCallVarTraces(Interp *iPtr, Var *arrayPtr, MODULE_SCOPE int TclCompareObjKeys(void *keyPtr, Tcl_HashEntry *hPtr); MODULE_SCOPE void TclFreeObjEntry(Tcl_HashEntry *hPtr); -MODULE_SCOPE TCL_HASH_TYPE TclHashObjKey(Tcl_HashTable *tablePtr, void *keyPtr); +MODULE_SCOPE size_t TclHashObjKey(Tcl_HashTable *tablePtr, void *keyPtr); MODULE_SCOPE int TclFullFinalizationRequested(void); @@ -4185,8 +4156,7 @@ MODULE_SCOPE Tcl_Size TclIndexDecode(int encoded, Tcl_Size endValue); */ MODULE_SCOPE int TclCommandWordLimitError(Tcl_Interp *interp, Tcl_Size count); - -#endif /* TCL_MAJOR_VERSION > 8 */ +MODULE_SCOPE int TclListLimitExceededError(Tcl_Interp *interp); /* Constants used in index value encoding routines. */ #define TCL_INDEX_END ((Tcl_Size)-2) diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 6c4da2a..232e987 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -171,7 +171,7 @@ EXTERN int TclObjInvoke(Tcl_Interp *interp, Tcl_Size objc, /* Slot 67 is reserved */ /* Slot 68 is reserved */ /* 69 */ -EXTERN void * TclpAlloc(TCL_HASH_TYPE size); +EXTERN void * TclpAlloc(size_t size); /* Slot 70 is reserved */ /* Slot 71 is reserved */ /* Slot 72 is reserved */ @@ -187,7 +187,7 @@ EXTERN unsigned long long TclpGetSeconds(void); /* Slot 79 is reserved */ /* Slot 80 is reserved */ /* 81 */ -EXTERN void * TclpRealloc(void *ptr, TCL_HASH_TYPE size); +EXTERN void * TclpRealloc(void *ptr, size_t size); /* Slot 82 is reserved */ /* Slot 83 is reserved */ /* Slot 84 is reserved */ @@ -440,8 +440,7 @@ EXTERN Tcl_Obj * TclGetObjNameOfExecutable(void); EXTERN void TclSetObjNameOfExecutable(Tcl_Obj *name, Tcl_Encoding encoding); /* 215 */ -EXTERN void * TclStackAlloc(Tcl_Interp *interp, - TCL_HASH_TYPE numBytes); +EXTERN void * TclStackAlloc(Tcl_Interp *interp, size_t numBytes); /* 216 */ EXTERN void TclStackFree(Tcl_Interp *interp, void *freePtr); /* 217 */ @@ -650,7 +649,7 @@ typedef struct TclIntStubs { void (*reserved66)(void); void (*reserved67)(void); void (*reserved68)(void); - void * (*tclpAlloc) (TCL_HASH_TYPE size); /* 69 */ + void * (*tclpAlloc) (size_t size); /* 69 */ void (*reserved70)(void); void (*reserved71)(void); void (*reserved72)(void); @@ -662,7 +661,7 @@ typedef struct TclIntStubs { void (*reserved78)(void); void (*reserved79)(void); void (*reserved80)(void); - void * (*tclpRealloc) (void *ptr, TCL_HASH_TYPE size); /* 81 */ + void * (*tclpRealloc) (void *ptr, size_t size); /* 81 */ void (*reserved82)(void); void (*reserved83)(void); void (*reserved84)(void); @@ -796,7 +795,7 @@ typedef struct TclIntStubs { void (*tclpFindExecutable) (const char *argv0); /* 212 */ Tcl_Obj * (*tclGetObjNameOfExecutable) (void); /* 213 */ void (*tclSetObjNameOfExecutable) (Tcl_Obj *name, Tcl_Encoding encoding); /* 214 */ - void * (*tclStackAlloc) (Tcl_Interp *interp, TCL_HASH_TYPE numBytes); /* 215 */ + void * (*tclStackAlloc) (Tcl_Interp *interp, size_t numBytes); /* 215 */ void (*tclStackFree) (Tcl_Interp *interp, void *freePtr); /* 216 */ int (*tclPushStackFrame) (Tcl_Interp *interp, Tcl_CallFrame **framePtrPtr, Tcl_Namespace *namespacePtr, int isProcCallFrame); /* 217 */ void (*tclPopStackFrame) (Tcl_Interp *interp); /* 218 */ @@ -1271,17 +1270,6 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclStaticLibrary) #endif /* defined(USE_TCL_STUBS) */ -#if (TCL_MAJOR_VERSION < 9) && defined(USE_TCL_STUBS) -#undef TclpGetClicks -#define TclpGetClicks() \ - ((unsigned long)tclIntStubsPtr->tclpGetClicks()) -#undef TclpGetSeconds -#define TclpGetSeconds() \ - ((unsigned long)tclIntStubsPtr->tclpGetSeconds()) -#undef TclGetObjInterpProc2 -#define TclGetObjInterpProc2 TclGetObjInterpProc -#endif - #undef TclUnusedStubEntry #define TclObjInterpProc TclGetObjInterpProc() #define TclObjInterpProc2 TclGetObjInterpProc2() diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h index aab3737..6d15408 100644 --- a/generic/tclIntPlatDecls.h +++ b/generic/tclIntPlatDecls.h @@ -30,492 +30,6 @@ * in the generic/tclInt.decls script. */ -#if TCL_MAJOR_VERSION < 9 - -#ifdef __cplusplus -extern "C" { -#endif - -/* - * Exported function declarations: - */ - -#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ -/* 0 */ -EXTERN void TclGetAndDetachPids(Tcl_Interp *interp, - Tcl_Channel chan); -/* 1 */ -EXTERN int TclpCloseFile(TclFile file); -/* 2 */ -EXTERN Tcl_Channel TclpCreateCommandChannel(TclFile readFile, - TclFile writeFile, TclFile errorFile, - int numPids, Tcl_Pid *pidPtr); -/* 3 */ -EXTERN int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe); -/* 4 */ -EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc, - const char **argv, TclFile inputFile, - TclFile outputFile, TclFile errorFile, - Tcl_Pid *pidPtr); -/* Slot 5 is reserved */ -/* 6 */ -EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction); -/* 7 */ -EXTERN TclFile TclpOpenFile(const char *fname, int mode); -/* 8 */ -EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout); -/* 9 */ -EXTERN TclFile TclpCreateTempFile(const char *contents); -/* 10 */ -EXTERN Tcl_DirEntry * TclpReaddir(TclDIR *dir); -/* Slot 11 is reserved */ -/* Slot 12 is reserved */ -/* Slot 13 is reserved */ -/* 14 */ -EXTERN int TclUnixCopyFile(const char *src, const char *dst, - const Tcl_StatBuf *statBufPtr, - int dontCopyAtts); -/* 15 */ -EXTERN int TclMacOSXGetFileAttribute(Tcl_Interp *interp, - int objIndex, Tcl_Obj *fileName, - Tcl_Obj **attributePtrPtr); -/* 16 */ -EXTERN int TclMacOSXSetFileAttribute(Tcl_Interp *interp, - int objIndex, Tcl_Obj *fileName, - Tcl_Obj *attributePtr); -/* 17 */ -EXTERN int TclMacOSXCopyFileAttributes(const char *src, - const char *dst, - const Tcl_StatBuf *statBufPtr); -/* 18 */ -EXTERN int TclMacOSXMatchType(Tcl_Interp *interp, - const char *pathName, const char *fileName, - Tcl_StatBuf *statBufPtr, - Tcl_GlobTypeData *types); -/* 19 */ -EXTERN void TclMacOSXNotifierAddRunLoopMode( - const void *runLoopMode); -/* Slot 20 is reserved */ -/* Slot 21 is reserved */ -/* Slot 22 is reserved */ -/* Slot 23 is reserved */ -/* Slot 24 is reserved */ -/* Slot 25 is reserved */ -/* Slot 26 is reserved */ -/* Slot 27 is reserved */ -/* Slot 28 is reserved */ -/* 29 */ -EXTERN int TclWinCPUID(int index, int *regs); -/* 30 */ -EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, - Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, - Tcl_Obj *resultingNameObj); -#endif /* UNIX */ -#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ -/* Slot 0 is reserved */ -/* Slot 1 is reserved */ -/* Slot 2 is reserved */ -/* Slot 3 is reserved */ -/* 4 */ -EXTERN void * TclWinGetTclInstance(void); -/* 5 */ -EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout); -/* Slot 6 is reserved */ -/* Slot 7 is reserved */ -/* 8 */ -EXTERN Tcl_Size TclpGetPid(Tcl_Pid pid); -/* Slot 9 is reserved */ -/* Slot 10 is reserved */ -/* 11 */ -EXTERN void TclGetAndDetachPids(Tcl_Interp *interp, - Tcl_Channel chan); -/* 12 */ -EXTERN int TclpCloseFile(TclFile file); -/* 13 */ -EXTERN Tcl_Channel TclpCreateCommandChannel(TclFile readFile, - TclFile writeFile, TclFile errorFile, - int numPids, Tcl_Pid *pidPtr); -/* 14 */ -EXTERN int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe); -/* 15 */ -EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc, - const char **argv, TclFile inputFile, - TclFile outputFile, TclFile errorFile, - Tcl_Pid *pidPtr); -/* 16 */ -EXTERN int TclpIsAtty(int fd); -/* 17 */ -EXTERN int TclUnixCopyFile(const char *src, const char *dst, - const Tcl_StatBuf *statBufPtr, - int dontCopyAtts); -/* 18 */ -EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction); -/* 19 */ -EXTERN TclFile TclpOpenFile(const char *fname, int mode); -/* 20 */ -EXTERN void TclWinAddProcess(void *hProcess, Tcl_Size id); -/* Slot 21 is reserved */ -/* 22 */ -EXTERN TclFile TclpCreateTempFile(const char *contents); -/* Slot 23 is reserved */ -/* 24 */ -EXTERN char * TclWinNoBackslash(char *path); -/* Slot 25 is reserved */ -/* Slot 26 is reserved */ -/* 27 */ -EXTERN void TclWinFlushDirtyChannels(void); -/* Slot 28 is reserved */ -/* 29 */ -EXTERN int TclWinCPUID(int index, int *regs); -/* 30 */ -EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, - Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, - Tcl_Obj *resultingNameObj); -#endif /* WIN */ -#ifdef MAC_OSX_TCL /* MACOSX */ -/* 0 */ -EXTERN void TclGetAndDetachPids(Tcl_Interp *interp, - Tcl_Channel chan); -/* 1 */ -EXTERN int TclpCloseFile(TclFile file); -/* 2 */ -EXTERN Tcl_Channel TclpCreateCommandChannel(TclFile readFile, - TclFile writeFile, TclFile errorFile, - int numPids, Tcl_Pid *pidPtr); -/* 3 */ -EXTERN int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe); -/* 4 */ -EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc, - const char **argv, TclFile inputFile, - TclFile outputFile, TclFile errorFile, - Tcl_Pid *pidPtr); -/* Slot 5 is reserved */ -/* 6 */ -EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction); -/* 7 */ -EXTERN TclFile TclpOpenFile(const char *fname, int mode); -/* 8 */ -EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout); -/* 9 */ -EXTERN TclFile TclpCreateTempFile(const char *contents); -/* 10 */ -EXTERN Tcl_DirEntry * TclpReaddir(TclDIR *dir); -/* Slot 13 is reserved */ -/* 14 */ -EXTERN int TclUnixCopyFile(const char *src, const char *dst, - const Tcl_StatBuf *statBufPtr, - int dontCopyAtts); -/* 15 */ -EXTERN int TclMacOSXGetFileAttribute(Tcl_Interp *interp, - int objIndex, Tcl_Obj *fileName, - Tcl_Obj **attributePtrPtr); -/* 16 */ -EXTERN int TclMacOSXSetFileAttribute(Tcl_Interp *interp, - int objIndex, Tcl_Obj *fileName, - Tcl_Obj *attributePtr); -/* 17 */ -EXTERN int TclMacOSXCopyFileAttributes(const char *src, - const char *dst, - const Tcl_StatBuf *statBufPtr); -/* 18 */ -EXTERN int TclMacOSXMatchType(Tcl_Interp *interp, - const char *pathName, const char *fileName, - Tcl_StatBuf *statBufPtr, - Tcl_GlobTypeData *types); -/* 19 */ -EXTERN void TclMacOSXNotifierAddRunLoopMode( - const void *runLoopMode); -/* Slot 20 is reserved */ -/* Slot 21 is reserved */ -/* Slot 22 is reserved */ -/* Slot 23 is reserved */ -/* Slot 24 is reserved */ -/* Slot 25 is reserved */ -/* Slot 26 is reserved */ -/* Slot 27 is reserved */ -/* Slot 28 is reserved */ -/* 29 */ -EXTERN int TclWinCPUID(int index, int *regs); -/* 30 */ -EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, - Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, - Tcl_Obj *resultingNameObj); -#endif /* MACOSX */ - -typedef struct TclIntPlatStubs { - int magic; - void *hooks; - -#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ - void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 0 */ - int (*tclpCloseFile) (TclFile file); /* 1 */ - Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */ - int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 3 */ - int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 4 */ - int (*tclUnixWaitForFile_) (int fd, int mask, int timeout); /* 5 */ - TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 6 */ - TclFile (*tclpOpenFile) (const char *fname, int mode); /* 7 */ - int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 8 */ - TclFile (*tclpCreateTempFile) (const char *contents); /* 9 */ - Tcl_DirEntry * (*tclpReaddir) (TclDIR *dir); /* 10 */ - void (*reserved11)(void); - void (*reserved12)(void); - void (*reserved13)(void); - int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 14 */ - int (*tclMacOSXGetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr); /* 15 */ - int (*tclMacOSXSetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj *attributePtr); /* 16 */ - int (*tclMacOSXCopyFileAttributes) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr); /* 17 */ - int (*tclMacOSXMatchType) (Tcl_Interp *interp, const char *pathName, const char *fileName, Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types); /* 18 */ - void (*tclMacOSXNotifierAddRunLoopMode) (const void *runLoopMode); /* 19 */ - void (*reserved20)(void); - void (*reserved21)(void); - TclFile (*tclpCreateTempFile_) (const char *contents); /* 22 */ - void (*reserved23)(void); - void (*reserved24)(void); - void (*reserved25)(void); - void (*reserved26)(void); - void (*reserved27)(void); - void (*reserved28)(void); - int (*tclWinCPUID) (int index, int *regs); /* 29 */ - int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */ -#endif /* UNIX */ -#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ - void (*reserved0)(void); - void (*reserved1)(void); - void (*reserved2)(void); - void (*reserved3)(void); - void * (*tclWinGetTclInstance) (void); /* 4 */ - int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 5 */ - void (*reserved6)(void); - void (*reserved7)(void); - Tcl_Size (*tclpGetPid) (Tcl_Pid pid); /* 8 */ - void (*reserved9)(void); - void *(*tclpReaddir) (void *dir); /* 10 */ - void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 11 */ - int (*tclpCloseFile) (TclFile file); /* 12 */ - Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 13 */ - int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 14 */ - int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 15 */ - int (*tclpIsAtty) (int fd); /* 16 */ - int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 17 */ - TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 18 */ - TclFile (*tclpOpenFile) (const char *fname, int mode); /* 19 */ - void (*tclWinAddProcess) (void *hProcess, Tcl_Size id); /* 20 */ - void (*reserved21)(void); - TclFile (*tclpCreateTempFile) (const char *contents); /* 22 */ - void (*reserved23)(void); - char * (*tclWinNoBackslash) (char *path); /* 24 */ - void (*reserved25)(void); - void (*reserved26)(void); - void (*tclWinFlushDirtyChannels) (void); /* 27 */ - void (*reserved28)(void); - int (*tclWinCPUID) (int index, int *regs); /* 29 */ - int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */ -#endif /* WIN */ -#ifdef MAC_OSX_TCL /* MACOSX */ - void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 0 */ - int (*tclpCloseFile) (TclFile file); /* 1 */ - Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */ - int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 3 */ - int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 4 */ - int (*tclUnixWaitForFile_) (int fd, int mask, int timeout); /* 5 */ - TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 6 */ - TclFile (*tclpOpenFile) (const char *fname, int mode); /* 7 */ - int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 8 */ - TclFile (*tclpCreateTempFile) (const char *contents); /* 9 */ - Tcl_DirEntry * (*tclpReaddir) (TclDIR *dir); /* 10 */ - void (*reserved11)(void); - void (*reserved12)(void); - void (*reserved13)(void); - int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 14 */ - int (*tclMacOSXGetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr); /* 15 */ - int (*tclMacOSXSetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj *attributePtr); /* 16 */ - int (*tclMacOSXCopyFileAttributes) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr); /* 17 */ - int (*tclMacOSXMatchType) (Tcl_Interp *interp, const char *pathName, const char *fileName, Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types); /* 18 */ - void (*tclMacOSXNotifierAddRunLoopMode) (const void *runLoopMode); /* 19 */ - void (*reserved20)(void); - void (*reserved21)(void); - TclFile (*tclpCreateTempFile_) (const char *contents); /* 22 */ - void (*reserved23)(void); - void (*reserved24)(void); - void (*reserved25)(void); - void (*reserved26)(void); - void (*reserved27)(void); - void (*reserved28)(void); - int (*tclWinCPUID) (int index, int *regs); /* 29 */ - int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */ -#endif /* MACOSX */ -} TclIntPlatStubs; - -extern const TclIntPlatStubs *tclIntPlatStubsPtr; - -#ifdef __cplusplus -} -#endif - -#if defined(USE_TCL_STUBS) - -/* - * Inline function declarations: - */ - -#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ -#define TclGetAndDetachPids \ - (tclIntPlatStubsPtr->tclGetAndDetachPids) /* 0 */ -#define TclpCloseFile \ - (tclIntPlatStubsPtr->tclpCloseFile) /* 1 */ -#define TclpCreateCommandChannel \ - (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 2 */ -#define TclpCreatePipe \ - (tclIntPlatStubsPtr->tclpCreatePipe) /* 3 */ -#define TclpCreateProcess \ - (tclIntPlatStubsPtr->tclpCreateProcess) /* 4 */ -/* Slot 5 is reserved */ -#define TclpMakeFile \ - (tclIntPlatStubsPtr->tclpMakeFile) /* 6 */ -#define TclpOpenFile \ - (tclIntPlatStubsPtr->tclpOpenFile) /* 7 */ -#define TclUnixWaitForFile \ - (tclIntPlatStubsPtr->tclUnixWaitForFile) /* 8 */ -#define TclpCreateTempFile \ - (tclIntPlatStubsPtr->tclpCreateTempFile) /* 9 */ -#define TclpReaddir \ - (tclIntPlatStubsPtr->tclpReaddir) /* 10 */ -/* Slot 11 is reserved */ -/* Slot 12 is reserved */ -/* Slot 13 is reserved */ -#define TclUnixCopyFile \ - (tclIntPlatStubsPtr->tclUnixCopyFile) /* 14 */ -#define TclMacOSXGetFileAttribute \ - (tclIntPlatStubsPtr->tclMacOSXGetFileAttribute) /* 15 */ -#define TclMacOSXSetFileAttribute \ - (tclIntPlatStubsPtr->tclMacOSXSetFileAttribute) /* 16 */ -#define TclMacOSXCopyFileAttributes \ - (tclIntPlatStubsPtr->tclMacOSXCopyFileAttributes) /* 17 */ -#define TclMacOSXMatchType \ - (tclIntPlatStubsPtr->tclMacOSXMatchType) /* 18 */ -#define TclMacOSXNotifierAddRunLoopMode \ - (tclIntPlatStubsPtr->tclMacOSXNotifierAddRunLoopMode) /* 19 */ -/* Slot 20 is reserved */ -/* Slot 21 is reserved */ -/* Slot 22 is reserved */ -/* Slot 23 is reserved */ -/* Slot 24 is reserved */ -/* Slot 25 is reserved */ -/* Slot 26 is reserved */ -/* Slot 27 is reserved */ -/* Slot 28 is reserved */ -#define TclWinCPUID \ - (tclIntPlatStubsPtr->tclWinCPUID) /* 29 */ -#define TclUnixOpenTemporaryFile \ - (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */ -#endif /* UNIX */ -#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ -/* Slot 0 is reserved */ -/* Slot 1 is reserved */ -/* Slot 2 is reserved */ -/* Slot 3 is reserved */ -#define TclWinGetTclInstance \ - (tclIntPlatStubsPtr->tclWinGetTclInstance) /* 4 */ -#define TclUnixWaitForFile \ - (tclIntPlatStubsPtr->tclUnixWaitForFile) /* 5 */ -/* Slot 6 is reserved */ -/* Slot 7 is reserved */ -#define TclpGetPid \ - (tclIntPlatStubsPtr->tclpGetPid) /* 8 */ -/* Slot 9 is reserved */ -/* Slot 10 is reserved */ -#define TclGetAndDetachPids \ - (tclIntPlatStubsPtr->tclGetAndDetachPids) /* 11 */ -#define TclpCloseFile \ - (tclIntPlatStubsPtr->tclpCloseFile) /* 12 */ -#define TclpCreateCommandChannel \ - (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 13 */ -#define TclpCreatePipe \ - (tclIntPlatStubsPtr->tclpCreatePipe) /* 14 */ -#define TclpCreateProcess \ - (tclIntPlatStubsPtr->tclpCreateProcess) /* 15 */ -#define TclpIsAtty \ - (tclIntPlatStubsPtr->tclpIsAtty) /* 16 */ -#define TclUnixCopyFile \ - (tclIntPlatStubsPtr->tclUnixCopyFile) /* 17 */ -#define TclpMakeFile \ - (tclIntPlatStubsPtr->tclpMakeFile) /* 18 */ -#define TclpOpenFile \ - (tclIntPlatStubsPtr->tclpOpenFile) /* 19 */ -#define TclWinAddProcess \ - (tclIntPlatStubsPtr->tclWinAddProcess) /* 20 */ -/* Slot 21 is reserved */ -#define TclpCreateTempFile \ - (tclIntPlatStubsPtr->tclpCreateTempFile) /* 22 */ -/* Slot 23 is reserved */ -#define TclWinNoBackslash \ - (tclIntPlatStubsPtr->tclWinNoBackslash) /* 24 */ -/* Slot 25 is reserved */ -/* Slot 26 is reserved */ -#define TclWinFlushDirtyChannels \ - (tclIntPlatStubsPtr->tclWinFlushDirtyChannels) /* 27 */ -/* Slot 28 is reserved */ -#define TclWinCPUID \ - (tclIntPlatStubsPtr->tclWinCPUID) /* 29 */ -#define TclUnixOpenTemporaryFile \ - (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */ -#endif /* WIN */ -#ifdef MAC_OSX_TCL /* MACOSX */ -#define TclGetAndDetachPids \ - (tclIntPlatStubsPtr->tclGetAndDetachPids) /* 0 */ -#define TclpCloseFile \ - (tclIntPlatStubsPtr->tclpCloseFile) /* 1 */ -#define TclpCreateCommandChannel \ - (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 2 */ -#define TclpCreatePipe \ - (tclIntPlatStubsPtr->tclpCreatePipe) /* 3 */ -#define TclpCreateProcess \ - (tclIntPlatStubsPtr->tclpCreateProcess) /* 4 */ -/* Slot 5 is reserved */ -#define TclpMakeFile \ - (tclIntPlatStubsPtr->tclpMakeFile) /* 6 */ -#define TclpOpenFile \ - (tclIntPlatStubsPtr->tclpOpenFile) /* 7 */ -#define TclUnixWaitForFile \ - (tclIntPlatStubsPtr->tclUnixWaitForFile) /* 8 */ -#define TclpCreateTempFile \ - (tclIntPlatStubsPtr->tclpCreateTempFile) /* 9 */ -#define TclpReaddir \ - (tclIntPlatStubsPtr->tclpReaddir) /* 10 */ -/* Slot 11 is reserved */ -/* Slot 12 is reserved */ -/* Slot 13 is reserved */ -#define TclUnixCopyFile \ - (tclIntPlatStubsPtr->tclUnixCopyFile) /* 14 */ -#define TclMacOSXGetFileAttribute \ - (tclIntPlatStubsPtr->tclMacOSXGetFileAttribute) /* 15 */ -#define TclMacOSXSetFileAttribute \ - (tclIntPlatStubsPtr->tclMacOSXSetFileAttribute) /* 16 */ -#define TclMacOSXCopyFileAttributes \ - (tclIntPlatStubsPtr->tclMacOSXCopyFileAttributes) /* 17 */ -#define TclMacOSXMatchType \ - (tclIntPlatStubsPtr->tclMacOSXMatchType) /* 18 */ -#define TclMacOSXNotifierAddRunLoopMode \ - (tclIntPlatStubsPtr->tclMacOSXNotifierAddRunLoopMode) /* 19 */ -/* Slot 20 is reserved */ -/* Slot 21 is reserved */ -/* Slot 22 is reserved */ -/* Slot 23 is reserved */ -/* Slot 24 is reserved */ -/* Slot 25 is reserved */ -/* Slot 26 is reserved */ -/* Slot 27 is reserved */ -/* Slot 28 is reserved */ -#define TclWinCPUID \ - (tclIntPlatStubsPtr->tclWinCPUID) /* 29 */ -#define TclUnixOpenTemporaryFile \ - (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */ -#endif /* MACOSX */ - -#endif /* defined(USE_TCL_STUBS) */ - -#else /* TCL_MAJOR_VERSION > 8 */ /* !BEGIN!: Do not edit below this line. */ #ifdef __cplusplus @@ -688,7 +202,6 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; #endif /* defined(USE_TCL_STUBS) */ /* !END!: Do not edit above this line. */ -#endif /* TCL_MAJOR_VERSION */ #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT @@ -719,7 +232,7 @@ MODULE_SCOPE int TclMacOSXMatchType(Tcl_Interp *interp, #endif #if defined(_WIN32) -# if !defined(TCL_NO_DEPRECATED) +# ifndef TCL_NO_DEPRECATED # define TclWinConvertError Tcl_WinConvertError # define TclWinConvertWSAError Tcl_WinConvertError # define TclWinNToHS ntohs diff --git a/generic/tclInterp.c b/generic/tclInterp.c index 5e54749..77d06f6 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -336,8 +336,8 @@ Tcl_Init( * pre-init and init scripts are running. The real version of this struct * is in tclPkg.c. */ - typedef struct PkgName_ { - struct PkgName_ *nextPtr;/* Next in list of package names being + typedef struct PkgNameStruct { + struct PkgNameStruct *nextPtr;/* Next in list of package names being * initialized. */ char name[4]; /* Enough space for "tcl". The *real* version * of this structure uses a flex array. */ @@ -4328,7 +4328,7 @@ TclRemoveScriptLimitCallbacks( while (hashPtr != NULL) { keyPtr = (ScriptLimitCallbackKey *) Tcl_GetHashKey(&iPtr->limit.callbacks, hashPtr); - Tcl_LimitRemoveHandler(keyPtr->interp, keyPtr->type, + Tcl_LimitRemoveHandler(keyPtr->interp, (int)keyPtr->type, CallScriptLimitCallback, Tcl_GetHashValue(hashPtr)); hashPtr = Tcl_NextHashEntry(&search); } diff --git a/generic/tclLink.c b/generic/tclLink.c index 746d74a..57bad3c 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -36,7 +36,7 @@ typedef struct { Tcl_Size bytes; /* Size of C variable array. This is 0 when * single variables, and >0 used for array * variables. */ - Tcl_Size numElems; /* Number of elements in C variable array. + Tcl_Size numElems; /* Number of elements in C variable array. * Zero for single variables. */ int type; /* Type of link (TCL_LINK_INT, etc.). */ union { @@ -680,7 +680,7 @@ GetInvalidDoubleFromObj( static char * LinkTraceProc( - void *clientData, /* Contains information about the link. */ + void *clientData, /* Contains information about the link. */ Tcl_Interp *interp, /* Interpreter containing Tcl variable. */ TCL_UNUSED(const char *) /*name1*/, TCL_UNUSED(const char *) /*name2*/, diff --git a/generic/tclListObj.c b/generic/tclListObj.c index d11fac9..87cc9c5 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -39,32 +39,31 @@ #ifdef ENABLE_LIST_ASSERTS -#define LIST_ASSERT(cond_) assert(cond_) +#define LIST_ASSERT(cond_) \ + assert(cond_) /* * LIST_INDEX_ASSERT is to catch errors with negative indices and counts * being passed AFTER validation. On Tcl9 length types are unsigned hence * the checks against LIST_MAX. On Tcl8 length types are signed hence the * also checks against 0. */ -#define LIST_INDEX_ASSERT(idxarg_) \ - do { \ - Tcl_Size idx_ = (idxarg_); /* To guard against ++ etc. */ \ - LIST_ASSERT(idx_ >= 0 && idx_ < LIST_MAX); \ +#define LIST_INDEX_ASSERT(idxarg_) \ + do { \ + Tcl_Size idx_ = (idxarg_); /* To guard against ++ etc. */ \ + LIST_ASSERT(idx_ >= 0 && idx_ < LIST_MAX); \ } while (0) /* Ditto for counts except upper limit is different */ -#define LIST_COUNT_ASSERT(countarg_) \ - do { \ - Tcl_Size count_ = (countarg_); /* To guard against ++ etc. */ \ - LIST_ASSERT(count_ >= 0 && count_ <= LIST_MAX); \ +#define LIST_COUNT_ASSERT(countarg_) \ + do { \ + Tcl_Size count_ = (countarg_); /* To guard against ++ etc. */ \ + LIST_ASSERT(count_ >= 0 && count_ <= LIST_MAX); \ } while (0) -#else - -#define LIST_ASSERT(cond_) ((void) 0) -#define LIST_INDEX_ASSERT(idx_) ((void) 0) -#define LIST_COUNT_ASSERT(count_) ((void) 0) - -#endif +#else // !ENABLE_LIST_ASSERTS +#define LIST_ASSERT(cond_) ((void) 0) +#define LIST_INDEX_ASSERT(idx_) ((void) 0) +#define LIST_COUNT_ASSERT(count_) ((void) 0) +#endif // ENABLE_LIST_ASSERTS /* Checks for when caller should have already converted to internal list type */ #define LIST_ASSERT_TYPE(listObj_) \ @@ -105,13 +104,15 @@ * - Finally if LISTREP_SPACE_ONLY_BACK is present, ALL extra space is at * the back. */ -#define LISTREP_PANIC_ON_FAIL 0x00000001 -#define LISTREP_SPACE_FAVOR_FRONT 0x00000002 -#define LISTREP_SPACE_FAVOR_BACK 0x00000004 -#define LISTREP_SPACE_ONLY_BACK 0x00000008 +enum ListRepresentationFlags { + LISTREP_PANIC_ON_FAIL = 1, + LISTREP_SPACE_FAVOR_FRONT = 2, + LISTREP_SPACE_FAVOR_BACK = 4, + LISTREP_SPACE_ONLY_BACK = 8 +}; #define LISTREP_SPACE_FAVOR_NONE \ (LISTREP_SPACE_FAVOR_FRONT | LISTREP_SPACE_FAVOR_BACK) -#define LISTREP_SPACE_FLAGS \ +#define LISTREP_SPACE_FLAGS \ (LISTREP_SPACE_FAVOR_FRONT | LISTREP_SPACE_FAVOR_BACK \ | LISTREP_SPACE_ONLY_BACK) @@ -119,7 +120,6 @@ * Prototypes for non-inline static functions defined later in this file: */ static int MemoryAllocationError(Tcl_Interp *, size_t size); -static int ListLimitExceededError(Tcl_Interp *); static ListStore *ListStoreNew(Tcl_Size objc, Tcl_Obj *const objv[], int flags); static int ListRepInit(Tcl_Size objc, Tcl_Obj *const objv[], int flags, ListRep *); static int ListRepInitAttempt(Tcl_Interp *, @@ -199,26 +199,26 @@ const Tcl_ObjType tclListType = { * passed ListRep) and frees it first. Additionally invalidates the string * representation. Generally used when modifying a Tcl_Obj value. */ -#define ListObjStompRep(objPtr_, repPtr_) \ - do { \ - (objPtr_)->internalRep.twoPtrValue.ptr1 = (repPtr_)->storePtr; \ - (objPtr_)->internalRep.twoPtrValue.ptr2 = (repPtr_)->spanPtr; \ - (objPtr_)->typePtr = &tclListType; \ +#define ListObjStompRep(objPtr_, repPtr_) \ + do { \ + (objPtr_)->internalRep.twoPtrValue.ptr1 = (repPtr_)->storePtr; \ + (objPtr_)->internalRep.twoPtrValue.ptr2 = (repPtr_)->spanPtr; \ + (objPtr_)->typePtr = &tclListType; \ } while (0) #define ListObjOverwriteRep(objPtr_, repPtr_) \ - do { \ - ListRepIncrRefs(repPtr_); \ - ListObjStompRep(objPtr_, repPtr_); \ + do { \ + ListRepIncrRefs(repPtr_); \ + ListObjStompRep(objPtr_, repPtr_); \ } while (0) -#define ListObjReplaceRepAndInvalidate(objPtr_, repPtr_) \ - do { \ - /* Note order important, don't use ListObjOverwriteRep! */ \ - ListRepIncrRefs(repPtr_); \ - TclFreeInternalRep(objPtr_); \ - TclInvalidateStringRep(objPtr_); \ - ListObjStompRep(objPtr_, repPtr_); \ +#define ListObjReplaceRepAndInvalidate(objPtr_, repPtr_) \ + do { \ + /* Note order important, don't use ListObjOverwriteRep! */ \ + ListRepIncrRefs(repPtr_); \ + TclFreeInternalRep(objPtr_); \ + TclInvalidateStringRep(objPtr_); \ + ListObjStompRep(objPtr_, repPtr_); \ } while (0) /* @@ -239,8 +239,8 @@ const Tcl_ObjType tclListType = { */ static inline ListSpan * ListSpanNew( - Tcl_Size firstSlot, /* Starting slot index of the span */ - Tcl_Size numSlots) /* Number of slots covered by the span */ + Tcl_Size firstSlot, /* Starting slot index of the span */ + Tcl_Size numSlots) /* Number of slots covered by the span */ { ListSpan *spanPtr = (ListSpan *) Tcl_Alloc(sizeof(*spanPtr)); spanPtr->refCount = 0; @@ -298,8 +298,8 @@ ListSpanDecrRefs( */ static inline int ListSpanMerited( - Tcl_Size length, /* Length of the proposed span */ - Tcl_Size usedStorageLength, /* Number of slots currently in used */ + Tcl_Size length, /* Length of the proposed span */ + Tcl_Size usedStorageLength, /* Number of slots currently in used */ Tcl_Size allocatedStorageLength) /* Length of the currently allocation */ { /* @@ -370,9 +370,9 @@ ListRepFreeUnreferenced( */ static inline void ObjArrayIncrRefs( - Tcl_Obj * const *objv, /* Pointer to the array */ - Tcl_Size startIdx, /* Starting index of subarray within objv */ - Tcl_Size count) /* Number of elements in the subarray */ + Tcl_Obj * const *objv, /* Pointer to the array */ + Tcl_Size startIdx, /* Starting index of subarray within objv */ + Tcl_Size count) /* Number of elements in the subarray */ { Tcl_Obj *const *end; LIST_INDEX_ASSERT(startIdx); @@ -402,9 +402,9 @@ ObjArrayIncrRefs( */ static inline void ObjArrayDecrRefs( - Tcl_Obj * const *objv, /* Pointer to the array */ - Tcl_Size startIdx, /* Starting index of subarray within objv */ - Tcl_Size count) /* Number of elements in the subarray */ + Tcl_Obj * const *objv, /* Pointer to the array */ + Tcl_Size startIdx, /* Starting index of subarray within objv */ + Tcl_Size count) /* Number of elements in the subarray */ { Tcl_Obj * const *end; LIST_INDEX_ASSERT(startIdx); @@ -434,9 +434,9 @@ ObjArrayDecrRefs( */ static inline void ObjArrayCopy( - Tcl_Obj **to, /* Destination */ - Tcl_Size count, /* Number of pointers to copy */ - Tcl_Obj *const from[]) /* Source array of Tcl_Obj* */ + Tcl_Obj **to, /* Destination */ + Tcl_Size count, /* Number of pointers to copy */ + Tcl_Obj *const from[]) /* Source array of Tcl_Obj* */ { Tcl_Obj **end; LIST_COUNT_ASSERT(count); @@ -465,8 +465,8 @@ ObjArrayCopy( */ static int MemoryAllocationError( - Tcl_Interp *interp, /* Interpreter for error message. May be NULL */ - size_t size) /* Size of attempted allocation that failed */ + Tcl_Interp *interp, /* Interpreter for error message. May be NULL */ + size_t size) /* Size of attempted allocation that failed */ { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -481,7 +481,7 @@ MemoryAllocationError( /* *------------------------------------------------------------------------ * - * ListLimitExceeded -- + * TclListLimitExceededError -- * * Generates an error for exceeding maximum list size. * @@ -493,13 +493,19 @@ MemoryAllocationError( * *------------------------------------------------------------------------ */ -static int -ListLimitExceededError( +int +TclListLimitExceededError( Tcl_Interp *interp) { + /* + * As an aside, note there is no parameter passed for the bad length + * because the cverflow is computationally detected and does not fit + * in Tcl_Size. + */ if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "max length of a Tcl list exceeded", -1)); + Tcl_SetObjResult(interp, + Tcl_ObjPrintf("max length (%" TCL_SIZE_MODIFIER + "d) of a Tcl list exceeded", (Tcl_Size)LIST_MAX)); Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL); } return TCL_ERROR; @@ -640,12 +646,12 @@ ListRepValidate( (void)storePtr; /* To stop gcc from whining about unused vars */ -#define INVARIANT(cond_) \ - do { \ - if (!(cond_)) { \ - condition = #cond_; \ - goto failure; \ - } \ +#define INVARIANT(cond_) \ + do { \ + if (!(cond_)) { \ + condition = #cond_; \ + goto failure; \ + } \ } while (0) /* Separate each condition so line number gives exact reason for failure */ @@ -671,14 +677,11 @@ ListRepValidate( INVARIANT(ListRepStart(repPtr) <= (storePtr->firstUsed + storePtr->numUsed - ListRepLength(repPtr))); #undef INVARIANT - return; -failure: + failure: Tcl_Panic("List internal failure in %s line %d. Condition: %s", - file, - lineNum, - condition); + file, lineNum, condition); } /* @@ -705,7 +708,7 @@ TclListObjValidate( ListRep listRep; if (TclListObjGetRep(interp, listObj, &listRep) != TCL_OK) { Tcl_Panic("Object passed to TclListObjValidate cannot be converted to " - "a list object."); + "a list object."); } ListRepValidate(&listRep, __FILE__, __LINE__); } @@ -942,7 +945,7 @@ ListRepInitAttempt( if (result != TCL_OK && interp != NULL) { if (objc > LIST_MAX) { - ListLimitExceededError(interp); + TclListLimitExceededError(interp); } else { MemoryAllocationError(interp, LIST_SIZE(objc)); } @@ -1197,6 +1200,7 @@ Tcl_DbNewListObj( * *------------------------------------------------------------------------ */ +#if 0 Tcl_Obj * TclNewListObj2( Tcl_Size objc1, /* Count of objects referenced by objv1. */ @@ -1230,6 +1234,7 @@ TclNewListObj2( storePtr->numUsed = objc; return listObj; } +#endif /* *---------------------------------------------------------------------- @@ -1258,10 +1263,10 @@ TclNewListObj2( static int TclListObjGetRep( - Tcl_Interp *interp, /* Used to report errors if not NULL. */ - Tcl_Obj *listObj, /* List object for which an element array is - * to be returned. */ - ListRep *repPtr) /* Location to store descriptor */ + Tcl_Interp *interp, /* Used to report errors if not NULL. */ + Tcl_Obj *listObj, /* List object for which an element array is + * to be returned. */ + ListRep *repPtr) /* Location to store descriptor */ { if (!TclHasInternalRep(listObj, &tclListType)) { int result; @@ -1457,10 +1462,10 @@ ListRepRange( if (rangeStart == 0 && rangeEnd == (numSrcElems-1)) { /* Option 0 - entire list. This may be used to canonicalize */ /* T:listrep-1.10.1,2.8.1 */ - *rangeRepPtr = *srcRepPtr; /* Not ref counts not incremented */ + *rangeRepPtr = *srcRepPtr; /* Note ref counts not incremented */ } else if (rangeStart == 0 && (!preserveSrcRep) && (!ListRepIsShared(srcRepPtr) && srcRepPtr->spanPtr == NULL)) { - /* Option 1 - Special case unshared, exclude end elements, no span */ + /* Option 1 - Special case unshared, exclude end elements, no span */ LIST_ASSERT(srcRepPtr->storePtr->firstUsed == 0); /* If no span */ ListRepElements(srcRepPtr, numSrcElems, srcElems); numAfterRangeEnd = numSrcElems - (rangeEnd + 1); @@ -1754,8 +1759,8 @@ Tcl_ListObjAppendList( * *------------------------------------------------------------------------ */ - int - TclListObjAppendElements ( +int +TclListObjAppendElements( Tcl_Interp *interp, /* Used to report errors if not NULL. */ Tcl_Obj *toObj, /* List object to append */ Tcl_Size elemCount, /* Number of elements in elemObjs[] */ @@ -1792,7 +1797,7 @@ Tcl_ListObjAppendList( ListRepElements(&listRep, toLen, toObjv); if (elemCount > LIST_MAX || toLen > (LIST_MAX - elemCount)) { - return ListLimitExceededError(interp); + return TclListLimitExceededError(interp); } finalLen = toLen + elemCount; @@ -2017,9 +2022,9 @@ Tcl_ListObjIndex( #undef Tcl_ListObjLength int Tcl_ListObjLength( - Tcl_Interp *interp, /* Used to report errors if not NULL. */ - Tcl_Obj *listObj, /* List object whose #elements to return. */ - Tcl_Size *lenPtr) /* The resulting length is stored here. */ + Tcl_Interp *interp, /* Used to report errors if not NULL. */ + Tcl_Obj *listObj, /* List object whose #elements to return. */ + Tcl_Size *lenPtr) /* The resulting length is stored here. */ { ListRep listRep; @@ -2138,7 +2143,7 @@ Tcl_ListObjReplace( } if (numToInsert > LIST_MAX - (origListLen - numToDelete)) { - return ListLimitExceededError(interp); + return TclListLimitExceededError(interp); } if ((first+numToDelete) >= origListLen) { @@ -2735,7 +2740,7 @@ TclLindexFlat( if (!TclHasInternalRep(listObj, &tclListType)) { status = SetListFromAny(interp, listObj); if (status != TCL_OK) { - /* The list is not a list at all => error. */ + /* The list is not a list at all => error. */ Tcl_DecrRefCount(listObj); return NULL; } @@ -2792,10 +2797,10 @@ TclLsetList( Tcl_Obj *indexArgObj, /* Index or index-list arg to 'lset'. */ Tcl_Obj *valueObj) /* Value arg to 'lset' or NULL to 'lpop'. */ { - Tcl_Size indexCount = 0; /* Number of indices in the index list. */ + Tcl_Size indexCount = 0; /* Number of indices in the index list. */ Tcl_Obj **indices = NULL; /* Vector of indices in the index list. */ Tcl_Obj *retValueObj; /* Pointer to the list to be returned. */ - Tcl_Size index; /* Current index in the list - discarded. */ + Tcl_Size index; /* Current index in the list - discarded. */ Tcl_Obj *indexListCopy; /* @@ -3165,7 +3170,7 @@ TclListObjSetElement( * element. */ { ListRep listRep; - Tcl_Obj **elemPtrs; /* Pointers to elements of the list. */ + Tcl_Obj **elemPtrs; /* Pointers to elements of the list. */ Tcl_Size elemCount; /* Number of elements in the list. */ /* Ensure that the listObj parameter designates an unshared list. */ @@ -3546,7 +3551,8 @@ UpdateStringOfList( elem = TclGetStringFromObj(elemPtrs[i], &length); bytesNeeded += TclScanElement(elem, length, flagPtr+i); if (bytesNeeded > SIZE_MAX - numElems) { - Tcl_Panic("max size for a Tcl value (%" TCL_Z_MODIFIER "u bytes) exceeded", SIZE_MAX); + Tcl_Panic("max size for a Tcl value (%" TCL_Z_MODIFIER "u bytes) exceeded", + SIZE_MAX); } } bytesNeeded += numElems - 1; @@ -3558,7 +3564,9 @@ UpdateStringOfList( start = dst = Tcl_InitStringRep(listObj, NULL, bytesNeeded); TclOOM(dst, bytesNeeded); for (i = 0; i < numElems; i++) { - flagPtr[i] |= (i ? TCL_DONT_QUOTE_HASH : 0); + if (i) { + flagPtr[i] |= TCL_DONT_QUOTE_HASH; + } elem = TclGetStringFromObj(elemPtrs[i], &length); dst += TclConvertElement(elem, length, dst, flagPtr[i]); *dst++ = ' '; @@ -3625,7 +3633,7 @@ TclListTestObj( ListObjReplaceRepAndInvalidate(listObj, &listRep); return listObj; } - + /* * Local Variables: * mode: c diff --git a/generic/tclListTypes.c b/generic/tclListTypes.c new file mode 100644 index 0000000..c40ec12 --- /dev/null +++ b/generic/tclListTypes.c @@ -0,0 +1,1086 @@ +/* + * tclListTypes.c -- + * + * This file contains functions that implement the Tcl abstract list + * object types. + * + * Copyright (c) 2025 Ashok P. Nadkarni. All rights reserved. + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#include <assert.h> +#include "tclInt.h" + +/* + * Since iterating is a little slower for abstract lists, we use a + * threshold to decide when to use the abstract list type. This is + * a tradeoff between memory usage and speed. + */ +#define LREVERSE_LENGTH_THRESHOLD 100 +#define LREPEAT_LENGTH_THRESHOLD 100 +#define LRANGE_LENGTH_THRESHOLD 100 + +/* + * We want the caller of the function that is operating on a list to be + * able to treat the passed in srcPtr and resultPtr independently when + * it comes to managing reference counts. Otherwise, it is very easy for + * the caller to mess up the reference counts of the two objects by not + * checking the result object is the same as the source object before + * decrementing reference counts for both, or incrementing and + * decrementing in the wrong order. To avoid this, we always return a + * new object. Note there is no guarantee the returned object is unshared. + */ +static inline Tcl_Obj * +TclMakeResultObj(Tcl_Obj *srcPtr, Tcl_Obj *resultPtr) +{ + return srcPtr == resultPtr ? Tcl_DuplicateObj(resultPtr) : resultPtr; +} + +/* + * Returns index of first matching entry in an array of Tcl_Obj, + * TCL_INDEX_NONE if not found. + */ +static Tcl_Size +FindInArrayOfObjs( + Tcl_Size haySize, + Tcl_Obj * const hayElems[], + Tcl_Obj *needlePtr) +{ + Tcl_Size needleLen; + const char *needle = TclGetStringFromObj(needlePtr, &needleLen); + for (int i = 0; i < haySize; i++) { + Tcl_Size hayElemLen; + const char *hayElem = TclGetStringFromObj(hayElems[i], &hayElemLen); + if (needleLen == hayElemLen && + memcmp(needle, hayElem, needleLen) == 0) { + return i; + } + } + return TCL_INDEX_NONE; +} + +/* + * TclObjArray stores a reference counted Tcl_Obj array. Basically, a + * cheaper, but less functional version of Tcl lists. + */ +typedef struct TclObjArray { + Tcl_Size refCount; /* Reference count */ + Tcl_Size nelems; /* Number of elements in the array */ + Tcl_Obj *elemPtrs[TCLFLEXARRAY]; + /* Variable size array */ +} TclObjArray; + +/* + * Allocate a new TclObjArray structure and initialize it with the + * given Tcl_Obj elements, incrementing their reference counts. + * The reference count of the array itself is initialized to 0. + */ +static TclObjArray * +TclObjArrayNew( + size_t nelems, + Tcl_Obj * const elemPtrs[]) +{ + TclObjArray *arrayPtr = (TclObjArray *)Tcl_Alloc( + offsetof(TclObjArray, elemPtrs) + nelems * sizeof(Tcl_Obj *)); + for (size_t i = 0; i < nelems; i++) { + Tcl_IncrRefCount(elemPtrs[i]); + arrayPtr->elemPtrs[i] = elemPtrs[i]; + } + arrayPtr->refCount = 0; + arrayPtr->nelems = nelems; + return arrayPtr; +} + +/* Add a reference to a TclObjArray */ +static inline void +TclObjArrayRef( + TclObjArray *arrayPtr) +{ + arrayPtr->refCount++; +} + +/* Frees a TclObjArray structure irrespective of the reference count. */ +static void +TclObjArrayFree( + TclObjArray *arrayPtr) +{ + for (Tcl_Size i = 0; i < arrayPtr->nelems; i++) { + Tcl_DecrRefCount(arrayPtr->elemPtrs[i]); + } + Tcl_Free(arrayPtr); +} + +/* + * Remove a reference from an TclObjArray, freeing it if no more remain. + * The reference count of the elements is decremented as well in that case. + */ +static inline void +TclObjArrayUnref( + TclObjArray *arrayPtr) +{ + if (arrayPtr->refCount <= 1) { + TclObjArrayFree(arrayPtr); + } else { + arrayPtr->refCount--; + } +} + +/* Returns count of elements in array and pointer to them in objPtrPtr */ +static inline Tcl_Size +TclObjArrayElems( + TclObjArray *arrayPtr, + Tcl_Obj ***objPtrPtr) +{ + *objPtrPtr = arrayPtr->elemPtrs; + return arrayPtr->nelems; +} + +/* Returns index of first matching entry, TCL_INDEX_NONE if not found */ +static inline Tcl_Size +TclObjArrayFind( + TclObjArray *arrayPtr, + Tcl_Obj *needlePtr) +{ + return FindInArrayOfObjs(arrayPtr->nelems, arrayPtr->elemPtrs, needlePtr); +} + +/* + * Compute the length of a range given start and end indices after normalizing + * the indices as follows: + * - the start index is bounded to 0 at the low end + * - the end index is bounded to one less than the length of the list at the + * high end and one less than the start index at the low end + * - the length of the normalized range is returned + * FUTURES - move to tclInt.h and use in other list implementations as well + */ +static inline Tcl_Size +TclNormalizeRangeLimits( + Tcl_Size *startPtr, + Tcl_Size *endPtr, + Tcl_Size len) +{ + assert(len >= 0); + if (*startPtr < 0) { + *startPtr = 0; + } + if (*endPtr >= len) { + *endPtr = len - 1; + } + if (*startPtr > *endPtr) { + *endPtr = *startPtr - 1; + } + return *endPtr - *startPtr + 1; +} + +/* + * TclListContainsValue -- + * + * Common function to locate a value in a list based on + * a string comparison of values. Note there is no guarantee in abstract + * lists about the order in which elements are searched so cannot use as + * a "find first" kind of function. + * + * Results: + * Standard Tcl result code. + * + * Side effects: + * Stores 1 in *foundPtr if the value is found, 0 otherwise. + */ +int +TclListContainsValue( + Tcl_Interp *interp, /* Used for error messages. May be NULL */ + Tcl_Obj *needlePtr, /* List to search */ + Tcl_Obj *hayPtr, /* List to search */ + int *foundPtr) /* Result */ +{ + /* Adapted from TEBCresume. */ + /* FUTURES - use this in TEBCresume INST_LIST_IN as well */ + + if (TclObjTypeHasProc(hayPtr, inOperProc)) { + return TclObjTypeInOperator(interp, needlePtr, hayPtr, foundPtr); + } + + Tcl_Size haySize; + + int status = TclListObjLength(interp, hayPtr, &haySize); + if (status != TCL_OK) { + return status; + } + + if (haySize == 0) { + *foundPtr = 0; + return TCL_OK; + } + + Tcl_Size needleLen; + const char *needle = TclGetStringFromObj(needlePtr, &needleLen); + + /* + * We iterate over an array in two cases: + * - the list is non-abstract. In this case, the array already exists + * and iteration is much faster than Tcl_ListObjIndex. + * - the list is abstract but does not have a index proc so we are + * forced shimmer to non-abstract array form. + */ + Tcl_ObjTypeIndexProc *indexProc = TclObjTypeHasProc(hayPtr, indexProc); + if (TclHasInternalRep(hayPtr, &tclListType) || indexProc == NULL) { + Tcl_Obj **hayElems; + TclListObjGetElements(interp, hayPtr, &haySize, &hayElems); + *foundPtr = (FindInArrayOfObjs(haySize, hayElems, + needlePtr) == TCL_INDEX_NONE) ? 0 : 1; + return TCL_OK; + } + + /* Abstract list */ + for (int i = 0; i < haySize; i++) { + Tcl_Obj *hayElemObj; + if (indexProc(interp, hayPtr, i, &hayElemObj) != TCL_OK) { + return TCL_ERROR; + } + assert(hayElemObj != NULL); // Should never be NULL for i < haySize + Tcl_Size hayElemLen; + const char *hayElem = TclGetStringFromObj(hayElemObj, &hayElemLen); + if (needleLen == hayElemLen && + memcmp(needle, hayElem, needleLen) == 0) { + *foundPtr = 1; + return TCL_OK; + } + } + *foundPtr = 0; + return TCL_OK; +} + +/* + *------------------------------------------------------------------------ + * + * TclAbstractListUpdateString -- + * + * Common function to update the string representation of an abstract list + * type. Adapted from UpdateStringOfList in tclListObj.c. + * Assumes no prior string representation exists. +* + * Results: + * None. + * + * Side effects: + * The string representation of the object is updated. + * + *------------------------------------------------------------------------ + */ +static void +TclAbstractListUpdateString( + Tcl_Obj *objPtr) +{ +#define LOCAL_SIZE 64 + char localFlags[LOCAL_SIZE], *flagPtr = NULL; + Tcl_Size numElems, i, length; + size_t bytesNeeded = 0; + Tcl_Obj *elemObj; + const char *elem; + char *start, *dst; + int ret; + + ret = Tcl_ListObjLength(NULL, objPtr, &numElems); + assert(ret == TCL_OK); // Should only be called for lists + (void) ret; // Avoid compiler warning + + /* Handle empty list case first, so rest of the routine is simpler. */ + + if (numElems == 0) { + objPtr->bytes = (char *)Tcl_Alloc(1); + objPtr->bytes[0] = '\0'; + objPtr->length = 0; + return; + } + + /* Pass 1: estimate space, gather flags. */ + if (numElems <= LOCAL_SIZE) { + flagPtr = localFlags; + } else { + flagPtr = (char *)Tcl_Alloc(numElems); + } + for (i = 0; i < numElems; i++) { + flagPtr[i] = (i ? TCL_DONT_QUOTE_HASH : 0); + ret = Tcl_ListObjIndex(NULL, objPtr, i, &elemObj); + assert(ret == TCL_OK); + elem = Tcl_GetStringFromObj(elemObj, &length); + bytesNeeded += TclScanElement(elem, length, flagPtr + i); + if (bytesNeeded > SIZE_MAX - numElems) { + Tcl_Panic("max size for a Tcl value (%" TCL_Z_MODIFIER + "u bytes) exceeded", + SIZE_MAX); + } +#if TCL_MAJOR_VERSION > 8 + Tcl_BounceRefCount(elemObj); +#endif + } + bytesNeeded += numElems; /* Including trailing nul */ + + /* + * Pass 2: copy into string rep buffer. + */ + + start = dst = (char *) Tcl_Alloc(bytesNeeded); + for (i = 0; i < numElems; i++) { + flagPtr[i] |= (i ? TCL_DONT_QUOTE_HASH : 0); + ret = Tcl_ListObjIndex(NULL, objPtr, i, &elemObj); + assert(ret == TCL_OK); + elem = Tcl_GetStringFromObj(elemObj, &length); + dst += TclConvertElement(elem, length, dst, flagPtr[i]); + *dst++ = ' '; + } + dst[-1] = '\0'; /* Overwrite last space */ + size_t finalLen = dst - start; /* Includes trailing nul */ + + /* If we are wasting "too many" bytes, attempt a reallocation */ + if (bytesNeeded > 1000 && (bytesNeeded-finalLen) > (bytesNeeded/4)) { + char *newBytes = (char *)Tcl_Realloc(start, finalLen); + if (newBytes != NULL) { + start = newBytes; + } + } + objPtr->bytes = start; + objPtr->length = finalLen-1; /* Exclude the trailing null */ + + if (flagPtr != localFlags) { + Tcl_Free(flagPtr); + } +} + +/* + * lreverseType - + * + * ------------------------------------------------------------------------ + * lreverseType is an abstract list type that contains the same elements as a + * given list but in reverse order. Implementation is straightforward with the + * target list stored in ptrAndSize.ptr field. Indexing is then just a question + * of mapping index of the reversed list to that of the original target. + * The ptrAndSize.size field is used as a length cache. + * ------------------------------------------------------------------------ + */ + +static Tcl_FreeInternalRepProc LreverseFreeIntrep; +static Tcl_DupInternalRepProc LreverseDupIntrep; +static Tcl_ObjTypeLengthProc LreverseTypeLength; +static Tcl_ObjTypeIndexProc LreverseTypeIndex; +static Tcl_ObjTypeReverseProc LreverseTypeReverse; +static Tcl_ObjTypeInOperatorProc LreverseTypeInOper; + +/* + * IMPORTANT - current implementation is read-only except for reverseProc. + * That is, the functions below that set or modify elements must be NULL. If + * you change this, be aware that both the object and internal + * representation (targetObj) may be shared and must be checked before + * modification. + */ +static const Tcl_ObjType lreverseType = { + "reversedList", /* name */ + LreverseFreeIntrep, /* freeIntRepProc */ + LreverseDupIntrep, /* dupIntRepProc */ + TclAbstractListUpdateString, /* updateStringProc */ + NULL, /* setFromAnyProc */ + TCL_OBJTYPE_V2(LreverseTypeLength, /* lengthProc */ + LreverseTypeIndex, /* indexProc */ + NULL, /* sliceProc */ + LreverseTypeReverse, /* reverseProc */ + NULL, /* getElementsProc */ + NULL, /* setElementProc - FUTURES */ + NULL, /* replaceProc - FUTURES */ + LreverseTypeInOper) /* inOperProc */ +}; + +static void +LreverseFreeIntrep( + Tcl_Obj *objPtr) +{ + Tcl_DecrRefCount((Tcl_Obj *)objPtr->internalRep.ptrAndSize.ptr); +} + +static void +LreverseDupIntrep( + Tcl_Obj *srcObj, + Tcl_Obj *dupObj) +{ + Tcl_Obj *targetObj = (Tcl_Obj *)srcObj->internalRep.ptrAndSize.ptr; + Tcl_IncrRefCount(targetObj); + dupObj->internalRep.ptrAndSize.ptr = targetObj; + dupObj->internalRep.ptrAndSize.size = srcObj->internalRep.ptrAndSize.size; + dupObj->typePtr = srcObj->typePtr; +} + +/* Implementation of Tcl_ObjType.lengthProc for lreverseType */ +static Tcl_Size +LreverseTypeLength( + Tcl_Obj *objPtr) +{ + return objPtr->internalRep.ptrAndSize.size; +} + +/* Implementation of Tcl_ObjType.indexProc for lreverseType */ +static int +LreverseTypeIndex( + Tcl_Interp *interp, + Tcl_Obj *objPtr, /* Source list */ + Tcl_Size index, /* Element index */ + Tcl_Obj **elemPtrPtr) /* Returned element */ +{ + Tcl_Obj *targetPtr = (Tcl_Obj *)objPtr->internalRep.ptrAndSize.ptr; + Tcl_Size len = objPtr->internalRep.ptrAndSize.size; + if (index < 0 || index >= len) { + *elemPtrPtr = NULL; + return TCL_OK; + } + index = len - index - 1; /* Reverse the index */ + return Tcl_ListObjIndex(interp, targetPtr, index, elemPtrPtr); +} + +/* Implementation of Tcl_ObjType.reverseProc for lreverseType */ +static int +LreverseTypeReverse( + Tcl_Interp *interp, + Tcl_Obj *objPtr, /* Operand */ + Tcl_Obj **reversedPtrPtr) /* Result */ +{ + (void)interp; /* Unused */ + /* Simple return the original */ + *reversedPtrPtr = (Tcl_Obj *) objPtr->internalRep.ptrAndSize.ptr; + return TCL_OK; +} + +/* Implementation of Tcl_ObjType.inOperProc for lreverseType */ +static int +LreverseTypeInOper( + Tcl_Interp *interp, + Tcl_Obj *needlePtr, /* Value to check */ + Tcl_Obj *hayPtr, /* List to search */ + int *foundPtr) /* Result */ +{ + Tcl_Obj *targetPtr = (Tcl_Obj *)hayPtr->internalRep.ptrAndSize.ptr; + return TclListContainsValue(interp, needlePtr, targetPtr, foundPtr); +} + +/* + *------------------------------------------------------------------------ + * + * Tcl_ListObjReverse -- + * + * Returns a Tcl_Obj containing a list with the same elements as the + * source list with elements in reverse order. + * + * Results: + * Standard Tcl result. + * + * Side effects: + * Stores the result in *resultPtrPtr. This will be different from + * objPtr, even if the latter is unshared and may be a new allocation, or + * a pointer to an internally stored object. In all cases, the reference + * count of the returned object is not incremented to account for the + * returned reference to it so caller should not decrement its reference + * count without incrementing (alternatively, use Tcl_BounceRefCount). + * + *------------------------------------------------------------------------ + */ +int +Tcl_ListObjReverse( + Tcl_Interp *interp, + Tcl_Obj *objPtr, /* Source whose elements are to be reversed */ + Tcl_Obj **reversedPtrPtr) /* Location to store result object */ +{ + Tcl_Obj *resultPtr; + + /* If the list is an AbstractList with a specialized reverse, use it. */ + if (TclObjTypeHasProc(objPtr, reverseProc)) { + if (TclObjTypeReverse(interp, objPtr, &resultPtr) == TCL_OK) { + *reversedPtrPtr = TclMakeResultObj(objPtr, resultPtr); + return TCL_OK; + } + /* Specialization does not work for this case. Try default path */ + } + + Tcl_Size elemc; + + /* Verify target is a list or can be converted to one */ + if (TclObjTypeHasProc(objPtr, lengthProc)) { + elemc = TclObjTypeLength(objPtr); + } else { + if (TclListObjLength(interp, objPtr, &elemc) != TCL_OK) { + *reversedPtrPtr = NULL; + return TCL_ERROR; + } + } + + if (elemc < 2) { + /* Cannot return the same list as returned Tcl_Obj must be different */ + *reversedPtrPtr = Tcl_DuplicateObj(objPtr); + return TCL_OK; + } + + if (elemc >= LREVERSE_LENGTH_THRESHOLD || objPtr->typePtr != &tclListType) { + TclNewObj(resultPtr); + TclInvalidateStringRep(resultPtr); + + Tcl_IncrRefCount(objPtr); + resultPtr->internalRep.ptrAndSize.ptr = objPtr; + resultPtr->internalRep.ptrAndSize.size = elemc; + resultPtr->typePtr = &lreverseType; + *reversedPtrPtr = resultPtr; + return TCL_OK; + } + + /* Non-abstract list small enough to copy. */ + + Tcl_Obj **elemv; + + if (TclListObjGetElements(interp, objPtr, &elemc, &elemv) != TCL_OK) { + *reversedPtrPtr = NULL; + return TCL_ERROR; + } + resultPtr = Tcl_NewListObj(elemc, NULL); + Tcl_Obj **dataArray = NULL; + ListRep listRep; + ListObjGetRep(resultPtr, &listRep); + dataArray = ListRepElementsBase(&listRep); + assert(dataArray); + listRep.storePtr->numUsed = elemc; + if (listRep.spanPtr) { + /* Future proofing in case Tcl_NewListObj returns a span */ + listRep.spanPtr->spanStart = listRep.storePtr->firstUsed; + listRep.spanPtr->spanLength = listRep.storePtr->numUsed; + } + for (Tcl_Size i = 0; i < elemc; i++) { + Tcl_IncrRefCount(elemv[i]); + dataArray[elemc - i - 1] = elemv[i]; + } + + *reversedPtrPtr = resultPtr; + return TCL_OK; +} + +/* + * lrepeatType - + * + * ------------------------------------------------------------------------ + * lrepeatType is an abstract list type that repeated elements. + * Implementation is straightforward with the elements stored in + * list stored in ptrAndSize.ptr and number of repetitions in + * ptrAndSize.size fields. Indexing is then just a question + * of mapping index of modulo length of list of repeated elements. + * ------------------------------------------------------------------------ + */ + +static Tcl_FreeInternalRepProc LrepeatFreeIntrep; +static Tcl_DupInternalRepProc LrepeatDupIntrep; +static Tcl_ObjTypeLengthProc LrepeatTypeLength; +static Tcl_ObjTypeIndexProc LrepeatTypeIndex; +static Tcl_ObjTypeInOperatorProc LrepeatTypeInOper; + +/* + * IMPORTANT - current implementation is read-only. That is, the + * functions below that set or modify elements are NULL. If you change + * this, be aware that both the object and internal representation + * may be shared must be checked before modification. + */ +static const Tcl_ObjType lrepeatType = { + "repeatedList", /* name */ + LrepeatFreeIntrep, /* freeIntRepProc */ + LrepeatDupIntrep, /* dupIntRepProc */ + TclAbstractListUpdateString, /* updateStringProc */ + NULL, /* setFromAnyProc */ + TCL_OBJTYPE_V2(LrepeatTypeLength, /* lengthProc */ + LrepeatTypeIndex, /* indexProc */ + NULL, /* sliceProc */ + NULL, /* Must be NULL - see above comment */ + NULL, /* getElementsProc */ + NULL, /* Must be NULL - see above comment */ + NULL, /* Must be NULL - see above comment */ + LrepeatTypeInOper) /* inOperProc */ +}; + +static void +LrepeatFreeIntrep( + Tcl_Obj *objPtr) +{ + TclObjArrayUnref((TclObjArray *)objPtr->internalRep.ptrAndSize.ptr); +} + +static void +LrepeatDupIntrep( + Tcl_Obj *srcObj, + Tcl_Obj *dupObj) +{ + TclObjArray *arrayPtr = (TclObjArray *)srcObj->internalRep.ptrAndSize.ptr; + TclObjArrayRef(arrayPtr); + dupObj->internalRep.ptrAndSize.ptr = arrayPtr; + dupObj->internalRep.ptrAndSize.size = srcObj->internalRep.ptrAndSize.size; + dupObj->typePtr = srcObj->typePtr; +} + +/* Implementation of Tcl_ObjType.lengthProc for lrepeatType */ +static Tcl_Size +LrepeatTypeLength( + Tcl_Obj *objPtr) +{ + return objPtr->internalRep.ptrAndSize.size; +} + +/* Implementation of Tcl_ObjType.indexProc for lrepeatType */ +static int +LrepeatTypeIndex( + Tcl_Interp *interp, + Tcl_Obj *objPtr, /* Source list */ + Tcl_Size index, /* Element index */ + Tcl_Obj **elemPtrPtr) /* Returned element */ +{ + (void) interp; /* Unused */ + Tcl_Size len = objPtr->internalRep.ptrAndSize.size; + if (index < 0 || index >= len) { + *elemPtrPtr = NULL; + return TCL_OK; + } + TclObjArray *arrayPtr = (TclObjArray *)objPtr->internalRep.ptrAndSize.ptr; + Tcl_Obj **elems; + Tcl_Size arraySize = TclObjArrayElems(arrayPtr, &elems); + index = index % arraySize; /* Modulo the size of the array */ + *elemPtrPtr = arrayPtr->elemPtrs[index]; + return TCL_OK; +} + +/* Implementation of Tcl_ObjType.inOperProc for lrepeatType */ +static int +LrepeatTypeInOper( + TCL_UNUSED(Tcl_Interp *), + Tcl_Obj *needlePtr, /* Value to check */ + Tcl_Obj *hayPtr, /* List to search */ + int *foundPtr) /* Result */ +{ + TclObjArray *arrayPtr = (TclObjArray *)hayPtr->internalRep.ptrAndSize.ptr; + Tcl_Size foundIndex = TclObjArrayFind(arrayPtr, needlePtr); + *foundPtr = foundIndex == TCL_INDEX_NONE ? 0 : 1; + return TCL_OK; +} + +/* + *------------------------------------------------------------------------ + * + * Tcl_ListObjRepeat -- + * + * Returns a Tcl_Obj containing a list whose elements are the same as the + * passed items repeated a given number of times. + * + * Results: + * Standard Tcl result. + * + * Side effects: + * Stores the result in *reversedPtrPtr. This may be a new allocation, or + * a pointer to an internally stored object. In all cases, the reference + * count of the returned object is not incremented to account for the + * returned reference to it so caller should not decrement its reference + * count without incrementing (alternatively, use Tcl_BounceRefCount). +. + * + *------------------------------------------------------------------------ + */ +int +Tcl_ListObjRepeat( + Tcl_Interp *interp, + Tcl_Size repeatCount, /* Number of times to repeat */ + Tcl_Size objc, /* Number of elements in objv */ + Tcl_Obj *const objv[], /* Source whose elements are to be repeated */ + Tcl_Obj **resultPtrPtr) /* Location to store result object */ +{ + if (repeatCount < 0) { + *resultPtrPtr = NULL; + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad count \"%" TCL_SIZE_MODIFIER "d\": must be integer >= 0", + repeatCount)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LREPEAT", "NEGARG", + (char *)NULL); + return TCL_ERROR; + } + + if (objc == 0 || repeatCount == 0) { + TclNewObj(*resultPtrPtr); + return TCL_OK; + } + + /* Final sanity check. Do not exceed limits on max list length. */ + if (objc > LIST_MAX/repeatCount) { + *resultPtrPtr = NULL; + return TclListLimitExceededError(interp); + } + Tcl_Size totalElems = objc * repeatCount; + + Tcl_Obj *resultPtr; + if (totalElems >= LREPEAT_LENGTH_THRESHOLD) { + TclObjArray *arrayPtr = TclObjArrayNew(objc, objv); + TclNewObj(resultPtr); + arrayPtr->refCount++; + TclInvalidateStringRep(resultPtr); + resultPtr->internalRep.ptrAndSize.ptr = arrayPtr; + resultPtr->internalRep.ptrAndSize.size = totalElems; + resultPtr->typePtr = &lrepeatType; + *resultPtrPtr = resultPtr; + return TCL_OK; + } + + assert(totalElems > 0); + + /* For small lists, create a copy as indexing is slightly faster */ + resultPtr = Tcl_NewListObj(totalElems, NULL); + Tcl_Obj **dataArray = NULL; + ListRep listRep; + ListObjGetRep(resultPtr, &listRep); + dataArray = ListRepElementsBase(&listRep); + listRep.storePtr->numUsed = totalElems; + if (listRep.spanPtr) { + /* Future proofing in case Tcl_NewListObj returns a span */ + listRep.spanPtr->spanStart = listRep.storePtr->firstUsed; + listRep.spanPtr->spanLength = listRep.storePtr->numUsed; + } + + /* + * Set the elements. Note that we handle the common degenerate case of a + * single value being repeated separately to permit the compiler as much + * room as possible to optimize a loop that might be run a very large + * number of times. + */ + + if (objc == 1) { + Tcl_Obj *tmpPtr = objv[0]; + + tmpPtr->refCount += repeatCount; + for (Tcl_Size i=0 ; i<totalElems ; i++) { + dataArray[i] = tmpPtr; + } + } else { + for (Tcl_Size i = 0, k = 0; i < repeatCount; i++) { + for (Tcl_Size j=0 ; j<objc ; j++) { + Tcl_IncrRefCount(objv[j]); + dataArray[k++] = objv[j]; + } + } + } + *resultPtrPtr = resultPtr; + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * lrangeType - + * + * lrangeType is an abstract list type holding a range of elements from a + * given list. The range is specified by a start index and count of elements. + * The type is a descriptor stored in the twoPtrValue.ptr1 field of Tcl_Obj. + * ------------------------------------------------------------------------ + */ +typedef struct LrangeRep { + Tcl_Obj *srcListPtr; /* Source list */ + Tcl_Size refCount; /* Reference count */ + Tcl_Size srcIndex; /* Start index of range in source list */ + Tcl_Size rangeLen; /* Number of elements in range */ +} LrangeRep; + +static Tcl_FreeInternalRepProc LrangeFreeIntrep; +static Tcl_DupInternalRepProc LrangeDupIntrep; +static Tcl_ObjTypeLengthProc LrangeTypeLength; +static Tcl_ObjTypeIndexProc LrangeTypeIndex; +static Tcl_ObjTypeSliceProc LrangeSlice; + +/* + * IMPORTANT - current implementation is read-only. That is, the + * functions below that set or modify elements are NULL. If you change + * this, be aware that both the object and internal representation + * may be shared and must be checked before modification. + */ +static const Tcl_ObjType lrangeType = { + "rangeList", /* name */ + LrangeFreeIntrep, /* freeIntRepProc */ + LrangeDupIntrep, /* dupIntRepProc */ + TclAbstractListUpdateString, /* updateStringProc */ + NULL, /* setFromAnyProc */ + TCL_OBJTYPE_V2(LrangeTypeLength, /* lengthProc */ + LrangeTypeIndex, /* indexProc */ + LrangeSlice, /* sliceProc */ + NULL, /* reverseProc, see above comment */ + NULL, /* getElementsProc */ + NULL, /* setElementProc, see above comment */ + NULL, /* replaceProc, see above comment */ + NULL) /* inOperProc */ +}; + +static inline int +LrangeMeetsLengthCriteria( + Tcl_Size rangeLen, + Tcl_Size srcLen) +{ + /* + * To use lrangeType, the range length + * - must not be much smaller (1/2?) than the source list as else + * it will potentially hold on to the Tcl_Obj's in the source list + * that are not within the range longer than necessary after the + * original source list is freed. + * - is at least LRANGE_LENGTH_THRESHOLD elements long as otherwise the + * memory savings is (probably) not worth the extra overhead of the + * accessing the abstract list. + */ + return (rangeLen >= LRANGE_LENGTH_THRESHOLD && + rangeLen >= srcLen / 2); +} + +/* Returns a new lrangeType object that references the source list */ +static int +LrangeNew( + Tcl_Obj *srcPtr, /* Source for the range */ + Tcl_Size srcIndex, /* Start of range in srcPtr */ + Tcl_Size rangeLen, /* Length of range */ + Tcl_Obj **resultPtrPtr) /* Location to store range object */ +{ + assert(srcIndex >= 0); + assert(rangeLen >= 0); + + /* Create a lrangeType referencing the original source list */ + LrangeRep *repPtr = (LrangeRep *)Tcl_Alloc(sizeof(LrangeRep)); + Tcl_Obj *resultPtr; + Tcl_IncrRefCount(srcPtr); + repPtr->refCount = 1; + repPtr->srcListPtr = srcPtr; + repPtr->srcIndex = srcIndex; + repPtr->rangeLen = rangeLen; + TclNewObj(resultPtr); + TclInvalidateStringRep(resultPtr); + resultPtr->internalRep.twoPtrValue.ptr1 = repPtr; + resultPtr->internalRep.twoPtrValue.ptr2 = NULL; + resultPtr->typePtr = &lrangeType; + *resultPtrPtr = resultPtr; + return TCL_OK; + +} + +static void +LrangeFreeIntrep( + Tcl_Obj *objPtr) +{ + LrangeRep *repPtr = (LrangeRep *)objPtr->internalRep.twoPtrValue.ptr1; + if (repPtr->refCount <= 1) { + Tcl_DecrRefCount(repPtr->srcListPtr); + Tcl_Free(repPtr); + } else { + repPtr->refCount--; + } +} + +static void +LrangeDupIntrep( + Tcl_Obj *srcObj, + Tcl_Obj *dupObj) +{ + LrangeRep *repPtr = (LrangeRep *)srcObj->internalRep.twoPtrValue.ptr1; + repPtr->refCount++; + dupObj->internalRep.twoPtrValue.ptr1 = repPtr; + dupObj->internalRep.twoPtrValue.ptr2 = NULL; + dupObj->typePtr = srcObj->typePtr; +} + +/* Implementation of Tcl_ObjType.lengthProc for lrangeType */ +static Tcl_Size +LrangeTypeLength( + Tcl_Obj *objPtr) +{ + LrangeRep *repPtr = (LrangeRep *)objPtr->internalRep.twoPtrValue.ptr1; + return repPtr->rangeLen; +} + +/* Implementation of Tcl_ObjType.indexProc for lrangeType */ +static int +LrangeTypeIndex( + Tcl_Interp *interp, + Tcl_Obj *objPtr, /* Source list */ + Tcl_Size index, /* Element index */ + Tcl_Obj **elemPtrPtr) /* Returned element */ +{ + LrangeRep *repPtr = (LrangeRep *)objPtr->internalRep.twoPtrValue.ptr1; + if (index < 0 || index >= repPtr->rangeLen) { + *elemPtrPtr = NULL; + return TCL_OK; + } + return Tcl_ListObjIndex(interp, repPtr->srcListPtr, + repPtr->srcIndex + index, elemPtrPtr); +} + +/* Implementation of Tcl_ObjType.sliceProc for lrangeType */ +static int +LrangeSlice( + Tcl_Interp *interp, + Tcl_Obj *objPtr, /* Source for the range */ + Tcl_Size start, /* Start index */ + Tcl_Size end, /* End index */ + Tcl_Obj **resultPtrPtr) /* Location to store result object */ +{ + assert(objPtr->typePtr == &lrangeType); + + Tcl_Size rangeLen; + LrangeRep *repPtr = (LrangeRep *)objPtr->internalRep.twoPtrValue.ptr1; + Tcl_Obj *sourcePtr = repPtr->srcListPtr; + + rangeLen = TclNormalizeRangeLimits(&start, &end, repPtr->rangeLen); + if (rangeLen == 0) { + TclNewObj(*resultPtrPtr); + return TCL_OK; + } + + /* + * Because of how ranges are constructed, they are never recursive. + * Not that the code below cares... + */ + assert(sourcePtr->typePtr != &lrangeType); + + Tcl_Size sourceLen; + Tcl_Size newSrcIndex = start + repPtr->srcIndex; + if (TclListObjLength(interp, sourcePtr, &sourceLen) != TCL_OK) { + /* Cannot fail because how rangeType's are constructed but ... */ + return TCL_ERROR; + } + + /* + * At this point, sourcePtr is a non-lrangeType that will be the source + * Tcl_Obj for the returned object. newSrcIndex is an index into this. + */ + + /* + * A range is always smaller than its source thus the following must + * hold even for recursive ranges. + */ + assert((newSrcIndex + rangeLen) <= sourceLen); + + /* + * We will only use the lrangeType abstract list if the following + * conditions are met: + * 1. The source list is not a non-abstract list since that has its + * own range operation with better performance and additional features. + * 2. The length criteria for using rangeType are met. + */ + if (sourcePtr->typePtr == &tclListType || + !LrangeMeetsLengthCriteria(rangeLen, sourceLen)) { + /* + * Conditions not met, create non-abstract list. + * Note TclListObjRange will modify the sourcePtr in place if it is + * not shared (refCount <=1). We do not want that since our repPtr + * is holding a reference to it and it might be the only reference. + * Thus we must increment the refCount before calling TclListObjRange. + */ + + Tcl_IncrRefCount(sourcePtr); + *resultPtrPtr = TclListObjRange(interp, sourcePtr, + newSrcIndex, newSrcIndex + rangeLen - 1); + assert(sourcePtr->refCount > 1); + Tcl_DecrRefCount(sourcePtr); + return *resultPtrPtr ? TCL_OK : TCL_ERROR; + } + + /* Modify in place if both Tcl_Obj and internal rep are unshared. */ + if (!Tcl_IsShared(objPtr) && repPtr->refCount < 2) { + /* Reuse this objPtr */ + repPtr->srcIndex = newSrcIndex; + repPtr->rangeLen = rangeLen; + Tcl_IncrRefCount(sourcePtr); /* Incr before decr ! */ + Tcl_DecrRefCount(repPtr->srcListPtr); + repPtr->srcListPtr = sourcePtr; + Tcl_InvalidateStringRep(objPtr); + *resultPtrPtr = objPtr; + return TCL_OK; + } else { + return LrangeNew(sourcePtr, newSrcIndex, rangeLen, resultPtrPtr); + } +} + +/* + *------------------------------------------------------------------------ + * + * Tcl_ListObjRange -- + * + * Returns a Tcl_Obj containing a list of elements from a given range + * in a source list. + * + * Results: + * Standard Tcl result. + * + * Side effects: + * Stores the result in *resultPtrPtr. This will be different from + * objPtr, even if the latter is unshared and may be a new allocation, or + * a pointer to an internally stored object. In all cases, the reference + * count of the returned object is not incremented to account for the + * returned reference to it so caller should not decrement its reference + * count without incrementing (alternatively, use Tcl_BounceRefCount). + * + *------------------------------------------------------------------------ + */ +int +Tcl_ListObjRange( + Tcl_Interp *interp, + Tcl_Obj *objPtr, /* Source for the range */ + Tcl_Size start, /* Start index */ + Tcl_Size end, /* End index */ + Tcl_Obj **resultPtrPtr) /* Location to store result object */ +{ + int result; + Tcl_Size srcLen; + Tcl_Obj *resultPtr; + + result = TclListObjLength(interp, objPtr, &srcLen); + if (result != TCL_OK) { + *resultPtrPtr = NULL; + return result; + } + + Tcl_Size rangeLen = TclNormalizeRangeLimits(&start, &end, srcLen); + if (rangeLen == 0) { + TclNewObj(*resultPtrPtr); + return TCL_OK; + } + + /* + * If the list is an AbstractList with a specialized slice, use it. + * Note this includes rangeType itself. Non-abstract lists already + * implement their own efficient range operation. + */ + if (TclObjTypeHasProc(objPtr, sliceProc)) { + result = TclObjTypeSlice(interp, objPtr, start, end, &resultPtr); + } else if (objPtr->typePtr == &tclListType) { + /* Do not use TclListObjRange for abstract lists as it will shimmer */ + resultPtr = TclListObjRange(interp, objPtr, start, end); + result = resultPtr ? TCL_OK : TCL_ERROR; + } else if (!LrangeMeetsLengthCriteria(rangeLen, srcLen)) { + /* Range is too small, create a non-abstract list */ + resultPtr = Tcl_NewListObj(rangeLen, NULL); + for (Tcl_Size i = 0; i < rangeLen; i++) { + Tcl_Obj *elemPtr; + result = Tcl_ListObjIndex(interp, objPtr, start + i, &elemPtr); + if (result != TCL_OK) { + break; + } + assert(elemPtr); + Tcl_ListObjAppendElement(interp, resultPtr, elemPtr); + } + } + else { + /* Create a lrangeType referencing the original source list */ + result = LrangeNew(objPtr, start, rangeLen, &resultPtr); + } + + if (result == TCL_OK) { + *resultPtrPtr = TclMakeResultObj(objPtr, resultPtr); + } else { + *resultPtrPtr = NULL; + } + return result; +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclLiteral.c b/generic/tclLiteral.c index 6720515..a1dbc03 100644 --- a/generic/tclLiteral.c +++ b/generic/tclLiteral.c @@ -29,9 +29,9 @@ */ static size_t AddLocalLiteralEntry(CompileEnv *envPtr, - Tcl_Obj *objPtr, int localHash); + Tcl_Obj *objPtr, size_t localHash); static void ExpandLocalLiteralArray(CompileEnv *envPtr); -static size_t HashString(const char *string, size_t length); +static size_t HashString(const char *string, Tcl_Size length); #ifdef TCL_COMPILE_DEBUG static LiteralEntry * LookupLiteralEntry(Tcl_Interp *interp, Tcl_Obj *objPtr); @@ -58,8 +58,7 @@ static void RebuildLiteralTable(LiteralTable *tablePtr); void TclInitLiteralTable( - LiteralTable *tablePtr) - /* Pointer to table structure, which is + LiteralTable *tablePtr) /* Pointer to table structure, which is * supplied by the caller. */ { #if (TCL_SMALL_HASH_TABLE != 4) @@ -176,11 +175,11 @@ TclDeleteLiteralTable( Tcl_Obj * TclCreateLiteral( Interp *iPtr, - const char *bytes, /* The start of the string. Note that this is + const char *bytes, /* The start of the string. Note that this is * not a NUL-terminated string. */ - Tcl_Size length, /* Number of bytes in the string. */ - size_t hash, /* The string's hash. If the value is - * TCL_INDEX_NONE, it will be computed here. */ + Tcl_Size length, /* Number of bytes in the string. */ + size_t hash, /* The string's hash. If the value is + * TCL_INDEX_NONE, it will be computed here. */ int *newPtr, Namespace *nsPtr, int flags, @@ -251,8 +250,9 @@ TclCreateLiteral( if ((flags & LITERAL_ON_HEAP)) { objPtr->bytes = (char *) bytes; objPtr->length = length; - } else { - TclInitStringRep(objPtr, bytes, length); + } else if (!TclAttemptInitStringRep(objPtr, bytes, length)) { + Tcl_DecrRefCount(objPtr); + return NULL; } /* Should the new literal be shared globally? */ @@ -389,12 +389,12 @@ TclFetchLiteral( int /* Do NOT change this type. Should not be wider than TclEmitPush operand*/ TclRegisterLiteral( - void *ePtr, /* Points to the CompileEnv in whose object + void *ePtr, /* Points to the CompileEnv in whose object * array an object is found or created. */ - const char *bytes, /* Points to string for which to find or + const char *bytes, /* Points to string for which to find or * create an object in CompileEnv's object * array. */ - Tcl_Size length, /* Number of bytes in the string. If -1, the + Tcl_Size length, /* Number of bytes in the string. If -1, the * string consists of all bytes up to the * first null character. */ int flags) /* If LITERAL_ON_HEAP then the caller already @@ -440,7 +440,7 @@ TclRegisterLiteral( if (objIndex > INT_MAX) { Tcl_Panic("Literal table index too large. Cannot be handled by TclEmitPush"); } - return objIndex; + return (int)objIndex; } } @@ -482,7 +482,7 @@ TclRegisterLiteral( Tcl_Panic( "Literal table index too large. Cannot be handled by TclEmitPush"); } - return objIndex; + return (int)objIndex; } #ifdef TCL_COMPILE_DEBUG @@ -507,7 +507,7 @@ static LiteralEntry * LookupLiteralEntry( Tcl_Interp *interp, /* Interpreter for which objPtr was created to * hold a literal. */ - Tcl_Obj *objPtr) /* Points to a Tcl object holding a literal + Tcl_Obj *objPtr) /* Points to a Tcl object holding a literal * that was previously created by a call to * TclRegisterLiteral. */ { @@ -553,7 +553,7 @@ void TclHideLiteral( Tcl_Interp *interp, /* Interpreter for which objPtr was created to * hold a literal. */ - CompileEnv *envPtr,/* Points to CompileEnv whose literal array + CompileEnv *envPtr, /* Points to CompileEnv whose literal array * contains the entry being hidden. */ int index) /* The index of the entry in the literal * array. */ @@ -617,7 +617,7 @@ TclHideLiteral( int TclAddLiteralObj( - CompileEnv *envPtr,/* Points to CompileEnv in whose literal array + CompileEnv *envPtr, /* Points to CompileEnv in whose literal array * the object is to be inserted. */ Tcl_Obj *objPtr, /* The object to insert into the array. */ LiteralEntry **litPtrPtr) /* The location where the pointer to the new @@ -647,7 +647,49 @@ TclAddLiteralObj( *litPtrPtr = lPtr; } - return objIndex; + return (int)objIndex; +} + +/* + *---------------------------------------------------------------------- + * + * TclRegisterLiteralObj -- + * + * Find, or if necessary create, an object in a CompileEnv literal array + * that has a string representation matching the argument object. + * + * Results: + * The index in the CompileEnv's literal array that references a shared + * literal matching the string. The object is created if necessary. + * + * Side effects: + * To maximize sharing, we look up the string in the interpreter's global + * literal table. If not found, we create a new shared literal in the + * global table. We then add a reference to the shared literal in the + * CompileEnv's literal array. + * + * The reference count of the argument object is bounced, so that the + * normal case where the object is zero ref count (as it is really acting + * as a local worker buffer) doesn't need explicit refcount handling by + * the caller. + * + *---------------------------------------------------------------------- + */ +int +TclRegisterLiteralObj( + CompileEnv *envPtr, /* Points to CompileEnv in whose literal array + * the object is to be inserted. */ + Tcl_Obj *objPtr, /* The object to insert into the array. */ + int flags) /* If LITERAL_CMD_NAME then the literal should + * not be shared across namespaces. + * LITERAL_ON_HEAP is unsupported/ignored. */ +{ + Tcl_Size length; + const char *bytes = Tcl_GetStringFromObj(objPtr, &length); + int num = TclRegisterLiteral(envPtr, bytes, length, + flags & ~LITERAL_ON_HEAP); + Tcl_BounceRefCount(objPtr); + return num; } /* @@ -670,10 +712,10 @@ TclAddLiteralObj( static size_t AddLocalLiteralEntry( - CompileEnv *envPtr,/* Points to CompileEnv in whose literal array + CompileEnv *envPtr, /* Points to CompileEnv in whose literal array * the object is to be inserted. */ Tcl_Obj *objPtr, /* The literal to add to the CompileEnv. */ - int localHash) /* Hash value for the literal's string. */ + size_t localHash) /* Hash value for the literal's string. */ { LiteralTable *localTablePtr = &envPtr->localLitTable; LiteralEntry *localPtr; @@ -749,7 +791,7 @@ AddLocalLiteralEntry( static void ExpandLocalLiteralArray( - CompileEnv *envPtr)/* Points to the CompileEnv whose object array + CompileEnv *envPtr) /* Points to the CompileEnv whose object array * must be enlarged. */ { /* @@ -831,7 +873,7 @@ void TclReleaseLiteral( Tcl_Interp *interp, /* Interpreter for which objPtr was created to * hold a literal. */ - Tcl_Obj *objPtr) /* Points to a literal object that was + Tcl_Obj *objPtr) /* Points to a literal object that was * previously created by a call to * TclRegisterLiteral. */ { @@ -911,8 +953,8 @@ TclReleaseLiteral( static size_t HashString( - const char *string, /* String for which to compute hash value. */ - size_t length) /* Number of bytes in the string. */ + const char *string, /* String for which to compute hash value. */ + Tcl_Size length) /* Number of bytes in the string. */ { size_t result = 0; @@ -975,8 +1017,7 @@ HashString( static void RebuildLiteralTable( - LiteralTable *tablePtr) - /* Local or global table to enlarge. */ + LiteralTable *tablePtr) /* Local or global table to enlarge. */ { LiteralEntry **oldBuckets; LiteralEntry **oldChainPtr, **newChainPtr; diff --git a/generic/tclLoad.c b/generic/tclLoad.c index 7e68744..0d06f90 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -86,6 +86,12 @@ typedef struct InterpLibrary { } InterpLibrary; /* + * Associated data key used to look up the linked list of libraries registered + * in the interpreter. + */ +#define ASSOC_KEY "tclLoad" + +/* * Prototypes for functions that are private to this file: */ @@ -132,7 +138,8 @@ Tcl_LoadObjCmd( Tcl_DString pfx, tmp, initName, safeInitName; Tcl_DString unloadName, safeUnloadName; InterpLibrary *ipFirstPtr, *ipPtr; - int code, namesMatch, filesMatch, offset; + int code, namesMatch, filesMatch; + Tcl_Size offset; const char *symbols[2]; Tcl_LibraryInitProc *initProc; const char *p, *fullFileName, *prefix; @@ -278,7 +285,7 @@ Tcl_LoadObjCmd( */ if (libraryPtr != NULL) { - ipFirstPtr = (InterpLibrary *)Tcl_GetAssocData(target, "tclLoad", NULL); + ipFirstPtr = (InterpLibrary *)Tcl_GetAssocData(target, ASSOC_KEY, NULL); for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { if (ipPtr->libraryPtr == libraryPtr) { code = TCL_OK; @@ -514,11 +521,11 @@ Tcl_LoadObjCmd( * static libraries at the head of the linked list! */ - ipFirstPtr = (InterpLibrary *)Tcl_GetAssocData(target, "tclLoad", NULL); + ipFirstPtr = (InterpLibrary *)Tcl_GetAssocData(target, ASSOC_KEY, NULL); ipPtr = (InterpLibrary *)Tcl_Alloc(sizeof(InterpLibrary)); ipPtr->libraryPtr = libraryPtr; ipPtr->nextPtr = ipFirstPtr; - Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc, ipPtr); + Tcl_SetAssocData(target, ASSOC_KEY, LoadCleanupProc, ipPtr); done: Tcl_DStringFree(&pfx); @@ -721,7 +728,7 @@ Tcl_UnloadObjCmd( code = TCL_ERROR; if (libraryPtr != NULL) { - ipFirstPtr = (InterpLibrary *)Tcl_GetAssocData(target, "tclLoad", NULL); + ipFirstPtr = (InterpLibrary *)Tcl_GetAssocData(target, ASSOC_KEY, NULL); for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { if (ipPtr->libraryPtr == libraryPtr) { code = TCL_OK; @@ -863,7 +870,7 @@ UnloadLibrary( */ if (!interpExiting) { - ipFirstPtr = (InterpLibrary *)Tcl_GetAssocData(target, "tclLoad", NULL); + ipFirstPtr = (InterpLibrary *)Tcl_GetAssocData(target, ASSOC_KEY, NULL); if (ipFirstPtr) { ipPtr = ipFirstPtr; if (ipPtr->libraryPtr == libraryPtr) { @@ -880,7 +887,7 @@ UnloadLibrary( } } Tcl_Free(ipPtr); - Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc, ipFirstPtr); + Tcl_SetAssocData(target, ASSOC_KEY, LoadCleanupProc, ipFirstPtr); } } @@ -1057,7 +1064,7 @@ Tcl_StaticLibrary( * it's already loaded. */ - ipFirstPtr = (InterpLibrary *)Tcl_GetAssocData(interp, "tclLoad", NULL); + ipFirstPtr = (InterpLibrary *)Tcl_GetAssocData(interp, ASSOC_KEY, NULL); for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { if (ipPtr->libraryPtr == libraryPtr) { return; @@ -1072,7 +1079,7 @@ Tcl_StaticLibrary( ipPtr = (InterpLibrary *)Tcl_Alloc(sizeof(InterpLibrary)); ipPtr->libraryPtr = libraryPtr; ipPtr->nextPtr = ipFirstPtr; - Tcl_SetAssocData(interp, "tclLoad", LoadCleanupProc, ipPtr); + Tcl_SetAssocData(interp, ASSOC_KEY, LoadCleanupProc, ipPtr); } } @@ -1132,7 +1139,7 @@ TclGetLoadedLibraries( if (target == NULL) { return TCL_ERROR; } - ipPtr = (InterpLibrary *)Tcl_GetAssocData(target, "tclLoad", NULL); + ipPtr = (InterpLibrary *)Tcl_GetAssocData(target, ASSOC_KEY, NULL); /* * Return information about all of the available libraries. diff --git a/generic/tclMain.c b/generic/tclMain.c index ad36b3f..e604a60 100644 --- a/generic/tclMain.c +++ b/generic/tclMain.c @@ -276,7 +276,7 @@ Tcl_SourceRCFile( TCL_NORETURN void Tcl_MainEx( - Tcl_Size argc, /* Number of arguments. */ + Tcl_Size argc, /* Number of arguments. */ TCHAR **argv, /* Array of argument strings. */ Tcl_AppInitProc *appInitProc, /* Application-specific initialization @@ -735,7 +735,7 @@ TclFullFinalizationRequested(void) static void StdinProc( - void *clientData, /* The state of interactive cmd line */ + void *clientData, /* The state of interactive cmd line */ TCL_UNUSED(int) /*mask*/) { int code; diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index fb4ec83..1138bcd 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -201,16 +201,15 @@ CreateChildEntry( Namespace *nsPtr, /* Parent namespace. */ const char *name) /* Simple name to look for. */ { - int newEntry; #ifndef BREAK_NAMESPACE_COMPAT - return Tcl_CreateHashEntry(&nsPtr->childTable, name, &newEntry); + return Tcl_CreateHashEntry(&nsPtr->childTable, name, NULL); #else if (nsPtr->childTablePtr == NULL) { nsPtr->childTablePtr = (Tcl_HashTable *) Tcl_Alloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(nsPtr->childTablePtr, TCL_STRING_KEYS); } - return Tcl_CreateHashEntry(nsPtr->childTablePtr, name, &newEntry); + return Tcl_CreateHashEntry(nsPtr->childTablePtr, name, NULL); #endif } @@ -2028,8 +2027,7 @@ Tcl_ForgetImport( */ Command *cmdPtr = (Command *) token; - ImportedCmdData *dataPtr = (ImportedCmdData *) - cmdPtr->objClientData; + ImportedCmdData *dataPtr = (ImportedCmdData *)cmdPtr->objClientData; Tcl_Command firstToken = (Tcl_Command) dataPtr->realCmdPtr; if (firstToken == origin) { @@ -2302,7 +2300,7 @@ TclGetNamespaceForQualName( * namespace if TCL_GLOBAL_ONLY was specified, * or the current namespace if cxtNsPtr was * NULL. */ - const char **simpleNamePtr) /* Address where function stores the simple + const char **simpleNamePtr) /* Address where function stores the simple * name at end of the qualName, or NULL if * qualName is "::" or the flag * TCL_FIND_ONLY_NS was specified. */ @@ -3744,7 +3742,8 @@ NamespaceForgetCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { const char *pattern; - int i, result; + int i; + int result; if (objc < 1) { Tcl_WrongNumArgs(interp, 1, objv, "?pattern pattern...?"); @@ -3810,8 +3809,8 @@ NamespaceImportCmd( { int allowOverwrite = 0; const char *string, *pattern; - int i, result; - int firstArg; + int i, firstArg; + int result; if (objc < 1) { Tcl_WrongNumArgs(interp, 1, objv, "?-force? ?pattern pattern...?"); @@ -5020,7 +5019,7 @@ TclLogCommandInfo( * the error. */ Tcl_Size length, /* Number of bytes in command (< 0 means use * all bytes up to first null byte). */ - const unsigned char *pc, /* Current pc of bytecode execution context */ + const unsigned char *pc, /* Current pc of bytecode execution context */ Tcl_Obj **tosPtr) /* Current stack of bytecode execution * context */ { diff --git a/generic/tclNotify.c b/generic/tclNotify.c index d4150fc..d9d332e 100644 --- a/generic/tclNotify.c +++ b/generic/tclNotify.c @@ -74,7 +74,7 @@ typedef struct ThreadSpecificData { /* Pointer to first event source in list of * event sources for this thread. */ Tcl_ThreadId threadId; /* Thread that owns this notifier instance. */ - void *clientData; /* Opaque handle for platform specific + void *clientData; /* Opaque handle for platform specific * notifier. */ struct ThreadSpecificData *nextPtr; /* Next notifier in global list of notifiers. @@ -308,7 +308,7 @@ Tcl_CreateEventSource( Tcl_EventCheckProc *checkProc, /* Function to call after waiting to see what * happened. */ - void *clientData) /* One-word argument to pass to setupProc and + void *clientData) /* One-word argument to pass to setupProc and * checkProc. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -347,7 +347,7 @@ Tcl_DeleteEventSource( Tcl_EventCheckProc *checkProc, /* Function to call after waiting to see what * happened. */ - void *clientData) /* One-word argument to pass to setupProc and + void *clientData) /* One-word argument to pass to setupProc and * checkProc. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -390,11 +390,11 @@ Tcl_DeleteEventSource( void Tcl_QueueEvent( Tcl_Event *evPtr, /* Event to add to queue. The storage space - * must have been allocated the caller with + * must have been allocated by the caller with * malloc (Tcl_Alloc), and it becomes the * property of the event queue. It will be * freed after the event has been handled. */ - int position) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, TCL_QUEUE_MARK, + int position) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, TCL_QUEUE_MARK, * possibly combined with TCL_QUEUE_ALERT_IF_EMPTY. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -426,7 +426,7 @@ Tcl_ThreadQueueEvent( * malloc (Tcl_Alloc), and it becomes the * property of the event queue. It will be * freed after the event has been handled. */ - int position) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, TCL_QUEUE_MARK, + int position) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, TCL_QUEUE_MARK, * possibly combined with TCL_QUEUE_ALERT_IF_EMPTY. */ { ThreadSpecificData *tsdPtr; @@ -486,7 +486,7 @@ QueueEvent( * malloc (Tcl_Alloc), and it becomes the * property of the event queue. It will be * freed after the event has been handled. */ - int position) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, TCL_QUEUE_MARK, + int position) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, TCL_QUEUE_MARK, * possibly combined with TCL_QUEUE_ALERT_IF_EMPTY */ { int wasEmpty = 0; @@ -562,7 +562,7 @@ QueueEvent( void Tcl_DeleteEvents( Tcl_EventDeleteProc *proc, /* The function to call. */ - void *clientData) /* The type-specific data. */ + void *clientData) /* The type-specific data. */ { Tcl_Event *evPtr; /* Pointer to the event being examined */ Tcl_Event *prevPtr; /* Pointer to evPtr's predecessor, or NULL if @@ -1270,7 +1270,7 @@ Tcl_FinalizeNotifier( void Tcl_AlertNotifier( - void *clientData) /* Pointer to thread data. */ + void *clientData) /* Pointer to thread data. */ { if (tclNotifierHooks.alertNotifierProc) { tclNotifierHooks.alertNotifierProc(clientData); @@ -1327,7 +1327,7 @@ Tcl_ServiceModeHook( void Tcl_SetTimer( - const Tcl_Time *timePtr) /* Timeout value, may be NULL. */ + const Tcl_Time *timePtr) /* Timeout value, may be NULL. */ { if (tclNotifierHooks.setTimerProc) { tclNotifierHooks.setTimerProc(timePtr); @@ -1358,7 +1358,7 @@ Tcl_SetTimer( int Tcl_WaitForEvent( - const Tcl_Time *timePtr) /* Maximum block time, or NULL. */ + const Tcl_Time *timePtr) /* Maximum block time, or NULL. */ { if (tclNotifierHooks.waitForEventProc) { return tclNotifierHooks.waitForEventProc(timePtr); @@ -1397,7 +1397,7 @@ Tcl_CreateFileHandler( * called. */ Tcl_FileProc *proc, /* Function to call for each selected * event. */ - void *clientData) /* Arbitrary data to pass to proc. */ + void *clientData) /* Arbitrary data to pass to proc. */ { if (tclNotifierHooks.createFileHandlerProc) { tclNotifierHooks.createFileHandlerProc(fd, mask, proc, clientData); diff --git a/generic/tclOO.c b/generic/tclOO.c index 0da8b7f..1fa9470 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -25,21 +25,22 @@ static const struct StdCommands { Tcl_ObjCmdProc *objProc; Tcl_ObjCmdProc *nreProc; CompileProc *compileProc; + int flags; } ooCmds[] = { - {"define", TclOODefineObjCmd, NULL, NULL}, - {"objdefine", TclOOObjDefObjCmd, NULL, NULL}, - {"copy", TclOOCopyObjectCmd, NULL, NULL}, - {"DelegateName", TclOODelegateNameObjCmd, NULL, NULL}, - {NULL, NULL, NULL, NULL} + {"define", TclOODefineObjCmd, NULL, NULL, 0}, + {"objdefine", TclOOObjDefObjCmd, NULL, NULL, 0}, + {"copy", TclOOCopyObjectCmd, NULL, NULL, 0}, + {"DelegateName", TclOODelegateNameObjCmd, NULL, NULL, 0}, + {NULL, NULL, NULL, NULL, 0} }, helpCmds[] = { - {"callback", TclOOCallbackObjCmd, NULL, NULL}, - {"mymethod", TclOOCallbackObjCmd, NULL, NULL}, - {"classvariable", TclOOClassVariableObjCmd, NULL, NULL}, - {"link", TclOOLinkObjCmd, NULL, NULL}, - {"next", NULL, TclOONextObjCmd, TclCompileObjectNextCmd}, - {"nextto", NULL, TclOONextToObjCmd, TclCompileObjectNextToCmd}, - {"self", TclOOSelfObjCmd, NULL, TclCompileObjectSelfCmd}, - {NULL, NULL, NULL, NULL} + {"callback", TclOOCallbackObjCmd, NULL, NULL, 0}, + {"mymethod", TclOOCallbackObjCmd, NULL, NULL, 0}, + {"classvariable", TclOOClassVariableObjCmd, NULL, NULL, 0}, + {"link", TclOOLinkObjCmd, NULL, NULL, 0}, + {"next", NULL, TclOONextObjCmd, TclCompileObjectNextCmd, CMD_COMPILES_EXPANDED}, + {"nextto", NULL, TclOONextToObjCmd, TclCompileObjectNextToCmd, CMD_COMPILES_EXPANDED}, + {"self", TclOOSelfObjCmd, NULL, TclCompileObjectSelfCmd, 0}, + {NULL, NULL, NULL, NULL, 0} }; /* @@ -51,31 +52,31 @@ static const struct DefineCommands { Tcl_ObjCmdProc *objProc; int flag; } defineCmds[] = { - {"classmethod", TclOODefineClassMethodObjCmd, 0}, - {"constructor", TclOODefineConstructorObjCmd, 0}, + {"classmethod", TclOODefineClassMethodObjCmd, 0}, + {"constructor", TclOODefineConstructorObjCmd, 0}, {"definitionnamespace", TclOODefineDefnNsObjCmd, 0}, - {"deletemethod", TclOODefineDeleteMethodObjCmd, 0}, - {"destructor", TclOODefineDestructorObjCmd, 0}, - {"export", TclOODefineExportObjCmd, 0}, - {"forward", TclOODefineForwardObjCmd, 0}, - {"initialise", TclOODefineInitialiseObjCmd, 0}, - {"initialize", TclOODefineInitialiseObjCmd, 0}, - {"method", TclOODefineMethodObjCmd, 0}, - {"private", TclOODefinePrivateObjCmd, 0}, - {"renamemethod", TclOODefineRenameMethodObjCmd, 0}, - {"self", TclOODefineSelfObjCmd, 0}, - {"unexport", TclOODefineUnexportObjCmd, 0}, + {"deletemethod", TclOODefineDeleteMethodObjCmd, 0}, + {"destructor", TclOODefineDestructorObjCmd, 0}, + {"export", TclOODefineExportObjCmd, 0}, + {"forward", TclOODefineForwardObjCmd, 0}, + {"initialise", TclOODefineInitialiseObjCmd, 0}, + {"initialize", TclOODefineInitialiseObjCmd, 0}, + {"method", TclOODefineMethodObjCmd, 0}, + {"private", TclOODefinePrivateObjCmd, 0}, + {"renamemethod", TclOODefineRenameMethodObjCmd, 0}, + {"self", TclOODefineSelfObjCmd, 0}, + {"unexport", TclOODefineUnexportObjCmd, 0}, {NULL, NULL, 0} }, objdefCmds[] = { - {"class", TclOODefineClassObjCmd, 1}, - {"deletemethod", TclOODefineDeleteMethodObjCmd, 1}, - {"export", TclOODefineExportObjCmd, 1}, - {"forward", TclOODefineForwardObjCmd, 1}, - {"method", TclOODefineMethodObjCmd, 1}, - {"private", TclOODefinePrivateObjCmd, 1}, - {"renamemethod", TclOODefineRenameMethodObjCmd, 1}, - {"self", TclOODefineObjSelfObjCmd, 0}, - {"unexport", TclOODefineUnexportObjCmd, 1}, + {"class", TclOODefineClassObjCmd, 1}, + {"deletemethod", TclOODefineDeleteMethodObjCmd, 1}, + {"export", TclOODefineExportObjCmd, 1}, + {"forward", TclOODefineForwardObjCmd, 1}, + {"method", TclOODefineMethodObjCmd, 1}, + {"private", TclOODefinePrivateObjCmd, 1}, + {"renamemethod", TclOODefineRenameMethodObjCmd, 1}, + {"self", TclOODefineObjSelfObjCmd, 0}, + {"unexport", TclOODefineUnexportObjCmd, 1}, {NULL, NULL, 0} }; @@ -96,7 +97,7 @@ static int CloneClassMethod(Tcl_Interp *interp, Class *clsPtr, Method **newMPtrPtr); static int CloneObjectMethod(Tcl_Interp *interp, Object *oPtr, Method *mPtr, Tcl_Obj *namePtr); -static void DeletedHelpersNamespace(void *clientData); +static Tcl_NamespaceDeleteProc DeletedHelpersNamespace; static Tcl_NRPostProc FinalizeAlloc; static Tcl_NRPostProc FinalizeNext; static Tcl_NRPostProc FinalizeObjectCall; @@ -105,23 +106,17 @@ static void InitClassSystemRoots(Tcl_Interp *interp, Foundation *fPtr); static int InitFoundation(Tcl_Interp *interp); static Tcl_InterpDeleteProc KillFoundation; -static void MyDeleted(void *clientData); -static void ObjectNamespaceDeleted(void *clientData); +static Tcl_CmdDeleteProc MyDeleted; +static Tcl_NamespaceDeleteProc ObjectNamespaceDeleted; static Tcl_CommandTraceProc ObjectRenamedTrace; static inline void RemoveClass(Class **list, size_t num, size_t idx); static inline void RemoveObject(Object **list, size_t num, size_t idx); static inline void SquelchCachedName(Object *oPtr); -static int PublicNRObjectCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -static int PrivateNRObjectCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -static int MyClassNRObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); -static void MyClassDeleted(void *clientData); +static Tcl_ObjCmdProc PublicNRObjectCmd; +static Tcl_ObjCmdProc PrivateNRObjectCmd; +static Tcl_ObjCmdProc MyClassNRObjCmd; +static Tcl_CmdDeleteProc MyClassDeleted; /* * Methods in the oo::object and oo::class classes. First, we define a helper @@ -172,8 +167,9 @@ static const char initScript[] = "package ifneeded TclOO " TCLOO_PATCHLEVEL " {# Already present, OK?};" #endif "package ifneeded tcl::oo " TCLOO_PATCHLEVEL " {# Already present, OK?};" -"namespace eval ::oo { variable version " TCLOO_VERSION " };" -"namespace eval ::oo { variable patchlevel " TCLOO_PATCHLEVEL " };"; +"namespace eval ::oo {" +" variable version " TCLOO_VERSION " patchlevel " TCLOO_PATCHLEVEL +"};"; /* "tcl_findLibrary tcloo $oo::version $oo::version" */ /* " tcloo.tcl OO_LIBRARY oo::library;"; */ @@ -333,7 +329,8 @@ CreateCmdInNS( const char *name, Tcl_ObjCmdProc *cmdProc, Tcl_ObjCmdProc *nreProc, - CompileProc *compileProc) + CompileProc *compileProc, + int flags) { Command *cmdPtr; @@ -344,6 +341,7 @@ CreateCmdInNS( namespacePtr, cmdProc, NULL, NULL); cmdPtr->nreProc = nreProc; cmdPtr->compileProc = compileProc; + cmdPtr->flags |= flags; } /* @@ -453,7 +451,7 @@ InitFoundation( TclNewLiteralStringObj(namePtr, "new"); TclNewInstanceMethod(interp, (Tcl_Object) fPtr->classCls->thisPtr, - namePtr /* keeps ref */, 0 /* private */, NULL, NULL); + namePtr /*keeps ref*/, 0 /*private*/, NULL, NULL); Tcl_BounceRefCount(namePtr); fPtr->classCls->constructorPtr = (Method *) TclNewMethod( (Tcl_Class) fPtr->classCls, NULL, 0, &classConstructor, NULL); @@ -466,12 +464,12 @@ InitFoundation( for (i = 0 ; helpCmds[i].name ; i++) { CreateCmdInNS(interp, fPtr->helpersNs, helpCmds[i].name, helpCmds[i].objProc, helpCmds[i].nreProc, - helpCmds[i].compileProc); + helpCmds[i].compileProc, helpCmds[i].flags); } for (i = 0 ; ooCmds[i].name ; i++) { CreateCmdInNS(interp, fPtr->ooNs, ooCmds[i].name, ooCmds[i].objProc, ooCmds[i].nreProc, - ooCmds[i].compileProc); + ooCmds[i].compileProc, ooCmds[i].flags); } TclOOInitInfo(interp); @@ -499,10 +497,10 @@ InitFoundation( Tcl_CreateObjCommand(interp, "::oo::configuresupport::configurableobject::property", - TclOODefinePropertyCmd, (void *) 1, NULL); + TclOODefinePropertyCmd, INT2PTR(1) /*useInstance*/, NULL); Tcl_CreateObjCommand(interp, "::oo::configuresupport::configurableclass::property", - TclOODefinePropertyCmd, (void *) 0, NULL); + TclOODefinePropertyCmd, INT2PTR(0) /*useInstance*/, NULL); /* * Evaluate the remaining definitions, which are a compiled-in Tcl script. @@ -878,13 +876,13 @@ MyDeleted( * squelched. */ { Object *oPtr = (Object *) clientData; - Tcl_Size linkc, i; - Tcl_Obj **linkv, *link; if (oPtr->linkedCmdsList) { + Tcl_Size linkc, i; + Tcl_Obj **linkv; TclListObjGetElements(NULL, oPtr->linkedCmdsList, &linkc, &linkv); for (i=0 ; i<linkc ; i++) { - link = linkv[i]; + Tcl_Obj *link = linkv[i]; (void) Tcl_DeleteCommand(oPtr->fPtr->interp, TclGetString(link)); } Tcl_DecrRefCount(oPtr->linkedCmdsList); @@ -2935,7 +2933,6 @@ Tcl_ObjectContextInvokeNext( CallContext *contextPtr = (CallContext *) context; size_t savedIndex = contextPtr->index; size_t savedSkip = contextPtr->skip; - int result; if (contextPtr->index + 1 >= contextPtr->callPtr->numChain) { /* @@ -2945,22 +2942,11 @@ Tcl_ObjectContextInvokeNext( * unexpectedly. */ - const char *methodType; - if (Tcl_InterpDeleted(interp)) { return TCL_OK; } - - if (contextPtr->callPtr->flags & CONSTRUCTOR) { - methodType = "constructor"; - } else if (contextPtr->callPtr->flags & DESTRUCTOR) { - methodType = "destructor"; - } else { - methodType = "method"; - } - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "no next %s implementation", methodType)); + "no next %s implementation", TclOOContextTypeName(contextPtr))); OO_ERROR(interp, NOTHING_NEXT); return TCL_ERROR; } @@ -2982,8 +2968,8 @@ Tcl_ObjectContextInvokeNext( * Invoke the (advanced) method call context in the caller context. */ - result = Tcl_NRCallObjProc(interp, TclOOInvokeContext, contextPtr, objc, - objv); + int result = Tcl_NRCallObjProc(interp, TclOOInvokeContext, contextPtr, + objc, objv); /* * Restore the call chain context index as we've finished the inner invoke @@ -3014,22 +3000,11 @@ TclNRObjectContextInvokeNext( * unexpectedly. */ - const char *methodType; - if (Tcl_InterpDeleted(interp)) { return TCL_OK; } - - if (contextPtr->callPtr->flags & CONSTRUCTOR) { - methodType = "constructor"; - } else if (contextPtr->callPtr->flags & DESTRUCTOR) { - methodType = "destructor"; - } else { - methodType = "method"; - } - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "no next %s implementation", methodType)); + "no next %s implementation", TclOOContextTypeName(contextPtr))); OO_ERROR(interp, NOTHING_NEXT); return TCL_ERROR; } @@ -3206,10 +3181,10 @@ TclOOObjectMyName( Tcl_Interp *interp, Object *oPtr) { - Tcl_Obj *namePtr; if (!oPtr->myCommand) { return NULL; } + Tcl_Obj *namePtr; TclNewObj(namePtr); Tcl_GetCommandFullName(interp, oPtr->myCommand, namePtr); return namePtr; diff --git a/generic/tclOO.h b/generic/tclOO.h index 7adf559..41e9fbc 100644 --- a/generic/tclOO.h +++ b/generic/tclOO.h @@ -62,12 +62,8 @@ typedef struct Tcl_ObjectContext_ *Tcl_ObjectContext; typedef int (Tcl_MethodCallProc)(void *clientData, Tcl_Interp *interp, Tcl_ObjectContext objectContext, int objc, Tcl_Obj *const *objv); -#if TCL_MAJOR_VERSION > 8 typedef int (Tcl_MethodCallProc2)(void *clientData, Tcl_Interp *interp, Tcl_ObjectContext objectContext, Tcl_Size objc, Tcl_Obj *const *objv); -#else -#define Tcl_MethodCallProc2 Tcl_MethodCallProc -#endif typedef void (Tcl_MethodDeleteProc)(void *clientData); typedef int (Tcl_CloneProc)(Tcl_Interp *interp, void *oldClientData, void **newClientData); @@ -98,7 +94,6 @@ typedef struct Tcl_MethodType { * be copied directly. */ } Tcl_MethodType; -#if TCL_MAJOR_VERSION > 8 typedef struct Tcl_MethodType2 { int version; /* Structure version field. Always to be equal * to TCL_OO_METHOD_VERSION_2 in @@ -115,9 +110,6 @@ typedef struct Tcl_MethodType2 { * data, or NULL if the type-specific data can * be copied directly. */ } Tcl_MethodType2; -#else -#define Tcl_MethodType2 Tcl_MethodType -#endif /* * The correct value for the version field of the Tcl_MethodType structure. diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index 740e2cb..f72529f 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -76,9 +76,7 @@ FinalizeConstruction( * ---------------------------------------------------------------------- */ -/* - * Look up the delegate for a class. - */ +// Look up the delegate for a class. static inline Class * GetClassDelegate( Tcl_Interp *interp, @@ -93,7 +91,7 @@ GetClassDelegate( /* * Patches in the appropriate class delegates' superclasses. - * Sonewhat nessy because the list of superclasses isn't modified frequently. + * Sonewhat messy because the list of superclasses isn't modified frequently. */ static inline void SetDelegateSuperclasses( @@ -101,7 +99,7 @@ SetDelegateSuperclasses( Class *clsPtr, Class *delegatePtr) { - /* Build new list of superclasses */ + // Build new list of superclasses int i, j = delegatePtr->superclasses.num, k; Class *superPtr, **supers = (Class **) Tcl_Alloc(sizeof(Class *) * (delegatePtr->superclasses.num + clsPtr->superclasses.num)); @@ -126,14 +124,14 @@ SetDelegateSuperclasses( } } - /* Install new list of superclasses */ + // Install new list of superclasses; if (delegatePtr->superclasses.num) { Tcl_Free(delegatePtr->superclasses.list); } delegatePtr->superclasses.list = supers; delegatePtr->superclasses.num = j; - /* Definitely don't need to bump any epoch here */ + // Definitely don't need to bump any epoch here } /* @@ -145,16 +143,13 @@ InstallDelegateAsMixin( Class *clsPtr, Class *delegatePtr) { - Class **mixins; - int i; - if (clsPtr->thisPtr->mixins.num == 0) { TclOOObjectSetMixins(clsPtr->thisPtr, 1, &delegatePtr); return; } - mixins = (Class **) TclStackAlloc(interp, + Class **mixins = (Class **) TclStackAlloc(interp, sizeof(Class *) * (clsPtr->thisPtr->mixins.num + 1)); - for (i = 0; i < clsPtr->thisPtr->mixins.num; i++) { + for (int i = 0; i < clsPtr->thisPtr->mixins.num; i++) { mixins[i] = clsPtr->thisPtr->mixins.list[i]; if (mixins[i] == delegatePtr) { TclStackFree(interp, (void *) mixins); @@ -166,18 +161,16 @@ InstallDelegateAsMixin( TclStackFree(interp, mixins); } -/* - * Patches in the appropriate class delegates. - */ +// Patches in the appropriate class delegates. static void MixinClassDelegates( Tcl_Interp *interp, Object *oPtr, Tcl_Obj *delegateName) { - Class *clsPtr = oPtr->classPtr, *delegatePtr; + Class *clsPtr = oPtr->classPtr; if (clsPtr) { - delegatePtr = TclOOGetClassFromObj(interp, delegateName); + Class *delegatePtr = TclOOGetClassFromObj(interp, delegateName); if (delegatePtr) { SetDelegateSuperclasses(interp, clsPtr, delegatePtr); InstallDelegateAsMixin(interp, clsPtr, delegatePtr); @@ -204,9 +197,8 @@ TclOO_Class_Constructor( Tcl_Obj *const *objv) { Object *oPtr = (Object *) Tcl_ObjectContextObject(context); - size_t skip = Tcl_ObjectContextSkippedArgs(context); - Tcl_Obj **invoke, *delegateName; + size_t skip = Tcl_ObjectContextSkippedArgs(context); if ((size_t) objc > skip + 1) { Tcl_WrongNumArgs(interp, skip, objv, "?definitionScript?"); @@ -221,7 +213,7 @@ TclOO_Class_Constructor( * argument to [oo::define]. [Bug 680503] */ - delegateName = Tcl_ObjPrintf("%s:: oo ::delegate", + Tcl_Obj *delegateName = Tcl_ObjPrintf("%s:: oo ::delegate", oPtr->namespacePtr->fullName); Tcl_IncrRefCount(delegateName); Tcl_NewObjectInstance(interp, (Tcl_Class) oPtr->fPtr->classCls, @@ -242,7 +234,7 @@ TclOO_Class_Constructor( * Delegate to [oo::define] to do the work. */ - invoke = (Tcl_Obj **) TclStackAlloc(interp, 3 * sizeof(Tcl_Obj *)); + Tcl_Obj **invoke = (Tcl_Obj **) TclStackAlloc(interp, 3 * sizeof(Tcl_Obj *)); invoke[0] = oPtr->fPtr->defineName; invoke[1] = TclOOObjectName(interp, oPtr); invoke[2] = objv[objc - 1]; @@ -279,14 +271,13 @@ PostClassConstructor( Tcl_Obj **invoke = (Tcl_Obj **) data[0]; Object *oPtr = (Object *) data[1]; Tcl_Obj *delegateName = (Tcl_Obj *) data[2]; - Tcl_InterpState saved; TclDecrRefCount(invoke[0]); TclDecrRefCount(invoke[1]); TclDecrRefCount(invoke[2]); TclStackFree(interp, invoke); - saved = Tcl_SaveInterpState(interp, result); + Tcl_InterpState saved = Tcl_SaveInterpState(interp, result); MixinClassDelegates(interp, oPtr, delegateName); Tcl_DecrRefCount(delegateName); return Tcl_RestoreInterpState(interp, saved); @@ -1040,15 +1031,8 @@ TclOOLinkObjCmd( int objc, Tcl_Obj *const *objv) { - /* Set up common bits. */ + // Set up common bits. CallFrame *framePtr = ((Interp *) interp)->varFramePtr; - CallContext *context; - Object *oPtr; - Tcl_Obj *myCmd, **linkv, *src, *dst; - Tcl_Size linkc; - const char *srcStr; - int i; - if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "%s may only be called from inside a method", @@ -1056,31 +1040,34 @@ TclOOLinkObjCmd( OO_ERROR(interp, CONTEXT_REQUIRED); return TCL_ERROR; } - context = (CallContext *) framePtr->clientData; - oPtr = context->oPtr; + CallContext *context = (CallContext *) framePtr->clientData; + Object *oPtr = context->oPtr; if (!oPtr->myCommand) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "cannot link to non-existent callback handle")); OO_ERROR(interp, MY_GONE); return TCL_ERROR; } - myCmd = Tcl_NewObj(); + Tcl_Obj *myCmd = Tcl_NewObj(); Tcl_GetCommandFullName(interp, oPtr->myCommand, myCmd); if (!oPtr->linkedCmdsList) { oPtr->linkedCmdsList = Tcl_NewListObj(0, NULL); Tcl_IncrRefCount(oPtr->linkedCmdsList); } - /* For each argument */ - for (i=1; i<objc; i++) { - /* Parse as list of (one or) two items: source and destination names */ + // For each argument + for (int i=1; i<objc; i++) { + Tcl_Size linkc; + Tcl_Obj **linkv, *src, *dst; + + // Parse as list of (one or) two items: source and destination names if (TclListObjGetElements(interp, objv[i], &linkc, &linkv) != TCL_OK) { Tcl_BounceRefCount(myCmd); return TCL_ERROR; } switch (linkc) { case 1: - /* Degenerate case */ + // Degenerate case src = dst = linkv[0]; break; case 2: @@ -1095,21 +1082,21 @@ TclOOLinkObjCmd( return TCL_ERROR; } - /* Qualify the source if necessary */ - srcStr = TclGetString(src); + // Qualify the source if necessary + const char *srcStr = TclGetString(src); if (srcStr[0] != ':' || srcStr[1] != ':') { src = Tcl_ObjPrintf("%s::%s", context->oPtr->namespacePtr->fullName, srcStr); } - /* Make the alias command */ + // Make the alias command if (TclAliasCreate(interp, interp, interp, src, myCmd, 1, &dst) != TCL_OK) { Tcl_BounceRefCount(myCmd); Tcl_BounceRefCount(src); return TCL_ERROR; } - /* Remember the alias for cleanup if necessary */ + // Remember the alias for cleanup if necessary Tcl_ListObjAppendElement(NULL, oPtr->linkedCmdsList, src); } Tcl_BounceRefCount(myCmd); @@ -1173,11 +1160,6 @@ TclOONextToObjCmd( { Interp *iPtr = (Interp *) interp; CallFrame *framePtr = iPtr->varFramePtr; - Class *classPtr; - CallContext *contextPtr; - Tcl_Size i; - Tcl_Object object; - const char *methodType; /* * Start with sanity checks on the calling context to make sure that we @@ -1192,7 +1174,7 @@ TclOONextToObjCmd( OO_ERROR(interp, CONTEXT_REQUIRED); return TCL_ERROR; } - contextPtr = (CallContext *) framePtr->clientData; + CallContext *contextPtr = (CallContext *) framePtr->clientData; /* * Sanity check the arguments; we need the first one to refer to a class. @@ -1202,15 +1184,8 @@ TclOONextToObjCmd( Tcl_WrongNumArgs(interp, 1, objv, "class ?arg...?"); return TCL_ERROR; } - object = Tcl_GetObjectFromObj(interp, objv[1]); - if (object == NULL) { - return TCL_ERROR; - } - classPtr = ((Object *) object)->classPtr; + Class *classPtr = TclOOGetClassFromObj(interp, objv[1]); if (classPtr == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "\"%s\" is not a class", TclGetString(objv[1]))); - OO_ERROR(interp, CLASS_REQUIRED); return TCL_ERROR; } @@ -1220,6 +1195,7 @@ TclOONextToObjCmd( * allow jumping backwards! */ + Tcl_Size i; for (i=contextPtr->index+1 ; i<contextPtr->callPtr->numChain ; i++) { MInvoke *miPtr = &contextPtr->callPtr->chain[i]; @@ -1243,14 +1219,7 @@ TclOONextToObjCmd( * is on the chain but unreachable, or not on the chain at all. */ - if (contextPtr->callPtr->flags & CONSTRUCTOR) { - methodType = "constructor"; - } else if (contextPtr->callPtr->flags & DESTRUCTOR) { - methodType = "destructor"; - } else { - methodType = "method"; - } - + const char *methodType = TclOOContextTypeName(contextPtr); for (i=contextPtr->index ; i != TCL_INDEX_NONE ; i--) { MInvoke *miPtr = &contextPtr->callPtr->chain[i]; @@ -1606,8 +1575,6 @@ TclOOCallbackObjCmd( { Interp *iPtr = (Interp *) interp; CallFrame *framePtr = iPtr->varFramePtr; - CallContext *contextPtr; - Tcl_Obj *namePtr, *listPtr; /* * Start with sanity checks on the calling context to make sure that we @@ -1623,14 +1590,14 @@ TclOOCallbackObjCmd( return TCL_ERROR; } - contextPtr = (CallContext *) framePtr->clientData; + CallContext *contextPtr = (CallContext *) framePtr->clientData; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "method ..."); return TCL_ERROR; } - /* Get the [my] real name. */ - namePtr = TclOOObjectMyName(interp, contextPtr->oPtr); + // Get the [my] real name. + Tcl_Obj *namePtr = TclOOObjectMyName(interp, contextPtr->oPtr); if (!namePtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "no possible safe callback without my", TCL_AUTO_LENGTH)); @@ -1638,9 +1605,9 @@ TclOOCallbackObjCmd( return TCL_ERROR; } - /* No check that the method exists; could be dynamically added. */ + // No check that the method exists; could be dynamically added. - listPtr = Tcl_NewListObj(1, &namePtr); + Tcl_Obj *listPtr = Tcl_NewListObj(1, &namePtr); (void) TclListObjAppendElements(NULL, listPtr, objc-1, objv+1); Tcl_SetObjResult(interp, listPtr); return TCL_OK; @@ -1665,11 +1632,6 @@ TclOOClassVariableObjCmd( { Interp *iPtr = (Interp *) interp; CallFrame *framePtr = iPtr->varFramePtr; - CallContext *contextPtr; - Class *clsPtr; - Tcl_Namespace *clsNsPtr, *ourNsPtr; - Var *arrayPtr, *otherPtr; - int i; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "name ..."); @@ -1690,19 +1652,19 @@ TclOOClassVariableObjCmd( return TCL_ERROR; } - /* Get a reference to the class's namespace */ - contextPtr = (CallContext *) framePtr->clientData; - clsPtr = CurrentlyInvoked(contextPtr).mPtr->declaringClassPtr; + // Get a reference to the class's namespace + CallContext *contextPtr = (CallContext *) framePtr->clientData; + Class *clsPtr = CurrentlyInvoked(contextPtr).mPtr->declaringClassPtr; if (clsPtr == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "method not defined by a class", TCL_AUTO_LENGTH)); OO_ERROR(interp, UNMATCHED_CONTEXT); return TCL_ERROR; } - clsNsPtr = clsPtr->thisPtr->namespacePtr; + Tcl_Namespace *clsNsPtr = clsPtr->thisPtr->namespacePtr; - /* Check the list of variable names */ - for (i = 1; i < objc; i++) { + // Check the list of variable names + for (int i = 1; i < objc; i++) { const char *varName = TclGetString(objv[i]); if (Tcl_StringMatch(varName, "*(*)")) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -1720,12 +1682,12 @@ TclOOClassVariableObjCmd( } } - /* Lastly, link the caller's local variables to the class's variables */ - ourNsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr; - for (i = 1; i < objc; i++) { - /* Locate the other variable. */ + // Lastly, link the caller's local variables to the class's variables + Tcl_Namespace *ourNsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr; + for (int i = 1; i < objc; i++) { + // Locate the other variable. iPtr->varFramePtr->nsPtr = (Namespace *) clsNsPtr; - otherPtr = TclObjLookupVarEx(interp, objv[i], NULL, + Var *arrayPtr, *otherPtr = TclObjLookupVarEx(interp, objv[i], NULL, (TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG|TCL_AVOID_RESOLVERS), "access", /*createPart1*/ 1, /*createPart2*/ 0, &arrayPtr); iPtr->varFramePtr->nsPtr = (Namespace *) ourNsPtr; @@ -1733,7 +1695,7 @@ TclOOClassVariableObjCmd( return TCL_ERROR; } - /* Create the new variable and link it to otherPtr. */ + // Create the new variable and link it to otherPtr. if (TclPtrObjMakeUpvarIdx(interp, otherPtr, objv[i], 0, TCL_INDEX_NONE) != TCL_OK) { return TCL_ERROR; diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index 6c18b85..7000877 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -430,6 +430,29 @@ FinalizeMethodRefs( /* * ---------------------------------------------------------------------- * + * TclOOContextTypeName -- + * + * Get the name of the (high-level) type of method that a context is + * processing. Used for error message generation. + * + * ---------------------------------------------------------------------- + */ +const char * +TclOOContextTypeName( + CallContext *contextPtr) +{ + if (contextPtr->callPtr->flags & CONSTRUCTOR) { + return "constructor"; + } else if (contextPtr->callPtr->flags & DESTRUCTOR) { + return "destructor"; + } else { + return "method"; + } +} + +/* + * ---------------------------------------------------------------------- + * * TclOOGetSortedMethodList, TclOOGetSortedClassMethodList -- * * Discovers the list of method names supported by an object or class. @@ -437,7 +460,7 @@ FinalizeMethodRefs( * ---------------------------------------------------------------------- */ -int +Tcl_Size TclOOGetSortedMethodList( Object *oPtr, /* The object to get the method names for. */ Object *contextObj, /* From what context object we are inquiring. @@ -776,9 +799,7 @@ AddPrivateMethodNames( FOREACH_HASH(namePtr, mPtr, methodsTablePtr) { if (IS_PRIVATE(mPtr)) { - int isNew; - - hPtr = Tcl_CreateHashEntry(namesPtr, namePtr, &isNew); + hPtr = Tcl_CreateHashEntry(namesPtr, namePtr, NULL); Tcl_SetHashValue(hPtr, INT2PTR(IN_LIST)); } } @@ -804,7 +825,7 @@ AddStandardMethodName( Tcl_SetHashValue(hPtr, INT2PTR(isWanted)); } else if ((PTR2INT(Tcl_GetHashValue(hPtr)) & NO_IMPLEMENTATION) && mPtr->typePtr != NULL) { - int isWanted = PTR2INT(Tcl_GetHashValue(hPtr)); + Tcl_Size isWanted = PTR2INT(Tcl_GetHashValue(hPtr)); isWanted &= ~NO_IMPLEMENTATION; Tcl_SetHashValue(hPtr, INT2PTR(isWanted)); @@ -1554,14 +1575,13 @@ TclOOGetStereotypeCallChain( } } else { if (hPtr == NULL) { - int isNew; if (clsPtr->classChainCache == NULL) { clsPtr->classChainCache = (Tcl_HashTable *) Tcl_Alloc(sizeof(Tcl_HashTable)); Tcl_InitObjHashTable(clsPtr->classChainCache); } hPtr = Tcl_CreateHashEntry(clsPtr->classChainCache, - methodNameObj, &isNew); + methodNameObj, NULL); } callPtr->refCount++; Tcl_SetHashValue(hPtr, callPtr); diff --git a/generic/tclOODecls.h b/generic/tclOODecls.h index e855e69..cf55478 100644 --- a/generic/tclOODecls.h +++ b/generic/tclOODecls.h @@ -270,14 +270,4 @@ extern const TclOOStubs *tclOOStubsPtr; /* !END!: Do not edit above this line. */ -#if TCL_MAJOR_VERSION < 9 - /* TIP #630 */ -# undef Tcl_MethodIsType2 -# define Tcl_MethodIsType2 Tcl_MethodIsType -# undef Tcl_NewInstanceMethod2 -# define Tcl_NewInstanceMethod2 Tcl_NewInstanceMethod -# undef Tcl_NewMethod2 -# define Tcl_NewMethod2 Tcl_NewMethod -#endif - #endif /* _TCLOODECLS */ diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index 8d99b07..e3fbe3f 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -37,16 +37,17 @@ typedef struct DeclaredSlot { const Tcl_MethodType getterType; const Tcl_MethodType setterType; const Tcl_MethodType resolverType; + const char *defaultOp; // The default op, if not set by the class } DeclaredSlot; -#define SLOT(name,getter,setter,resolver) \ +#define SLOT(name,getter,setter,resolver,defOp) \ {"::oo::" name, \ {TCL_OO_METHOD_VERSION_1, "core method: " name " Getter", \ getter, NULL, NULL}, \ {TCL_OO_METHOD_VERSION_1, "core method: " name " Setter", \ setter, NULL, NULL}, \ {TCL_OO_METHOD_VERSION_1, "core method: " name " Resolver", \ - resolver, NULL, NULL}} + resolver, NULL, NULL}, (defOp)} typedef struct DeclaredSlotMethod { const char *name; @@ -190,26 +191,26 @@ static int ResolveClass(void *clientData, */ static const DeclaredSlot slots[] = { - SLOT("define::filter", ClassFilter_Get, ClassFilter_Set, NULL), - SLOT("define::mixin", ClassMixin_Get, ClassMixin_Set, ResolveClass), - SLOT("define::superclass", ClassSuper_Get, ClassSuper_Set, ResolveClass), - SLOT("define::variable", ClassVars_Get, ClassVars_Set, NULL), - SLOT("objdefine::filter", ObjFilter_Get, ObjFilter_Set, NULL), - SLOT("objdefine::mixin", ObjMixin_Get, ObjMixin_Set, ResolveClass), - SLOT("objdefine::variable", ObjVars_Get, ObjVars_Set, NULL), + SLOT("define::filter", ClassFilter_Get, ClassFilter_Set, NULL, NULL), + SLOT("define::mixin", ClassMixin_Get, ClassMixin_Set, ResolveClass, "-set"), + SLOT("define::superclass", ClassSuper_Get, ClassSuper_Set, ResolveClass, "-set"), + SLOT("define::variable", ClassVars_Get, ClassVars_Set, NULL, NULL), + SLOT("objdefine::filter", ObjFilter_Get, ObjFilter_Set, NULL, NULL), + SLOT("objdefine::mixin", ObjMixin_Get, ObjMixin_Set, ResolveClass, "-set"), + SLOT("objdefine::variable", ObjVars_Get, ObjVars_Set, NULL, NULL), SLOT("configuresupport::readableproperties", Configurable_ClassReadableProps_Get, - Configurable_ClassReadableProps_Set, NULL), + Configurable_ClassReadableProps_Set, NULL, NULL), SLOT("configuresupport::writableproperties", Configurable_ClassWritableProps_Get, - Configurable_ClassWritableProps_Set, NULL), + Configurable_ClassWritableProps_Set, NULL, NULL), SLOT("configuresupport::objreadableproperties", Configurable_ObjectReadableProps_Get, - Configurable_ObjectReadableProps_Set, NULL), + Configurable_ObjectReadableProps_Set, NULL, NULL), SLOT("configuresupport::objwritableproperties", Configurable_ObjectWritableProps_Get, - Configurable_ObjectWritableProps_Set, NULL), - {NULL, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}} + Configurable_ObjectWritableProps_Set, NULL, NULL), + {NULL, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}, 0} }; static const DeclaredSlotMethod slotMethods[] = { @@ -231,7 +232,7 @@ static const DeclaredSlotMethod slotMethods[] = { * used with Tcl_ObjPrintf(). */ -#define PRIVATE_VARIABLE_PATTERN "%d : %s" +#define PRIVATE_VARIABLE_PATTERN "%" TCL_Z_MODIFIER "d : %s" /* * ---------------------------------------------------------------------- @@ -671,7 +672,7 @@ InstallPrivateVariableMapping( PrivateVariableList *pvlPtr, Tcl_Size varc, Tcl_Obj *const *varv, - int creationEpoch) + Tcl_Size creationEpoch) { PrivateVariableMapping *privatePtr; Tcl_Size i, n; @@ -1230,6 +1231,119 @@ MagicDefinitionInvoke( /* * ---------------------------------------------------------------------- * + * ExportMethod, UnexportMethod, ExportInstanceMethod, UnexportInstanceMethod -- + * + * Exporting and unexporting are done by setting or removing the + * PUBLIC_METHOD flag on the method record. If there is no such method in + * this class or object (i.e. the method comes from something inherited + * from or that we're an instance of) then we put in a blank record just + * to hold that flag (or its absence); such records are skipped over by + * the call chain engine *except* for their flags member. + * + * Caller has the responsibility to update any epochs if necessary. + * + * ---------------------------------------------------------------------- + */ + +// Make a blank method record or look up the existing one. +static inline Method * +GetOrCreateMethod( + Tcl_HashTable *tablePtr, + Tcl_Obj *namePtr, + int *isNew) +{ + Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(tablePtr, namePtr, + isNew); + if (*isNew) { + Method *mPtr = (Method *) Tcl_Alloc(sizeof(Method)); + memset(mPtr, 0, sizeof(Method)); + mPtr->refCount = 1; + mPtr->namePtr = namePtr; + Tcl_IncrRefCount(namePtr); + Tcl_SetHashValue(hPtr, mPtr); + return mPtr; + } else { + return (Method *) Tcl_GetHashValue(hPtr); + } +} + +static int +ExportMethod( + Class *clsPtr, + Tcl_Obj *namePtr) +{ + int isNew; + Method *mPtr = GetOrCreateMethod(&clsPtr->classMethods, namePtr, &isNew); + if (isNew || !(mPtr->flags & (PUBLIC_METHOD | PRIVATE_METHOD))) { + mPtr->flags |= PUBLIC_METHOD; + mPtr->flags &= ~TRUE_PRIVATE_METHOD; + isNew = 1; + } + return isNew; +} + +static int +UnexportMethod( + Class *clsPtr, + Tcl_Obj *namePtr) +{ + int isNew; + Method *mPtr = GetOrCreateMethod(&clsPtr->classMethods, namePtr, &isNew); + if (isNew || mPtr->flags & (PUBLIC_METHOD | TRUE_PRIVATE_METHOD)) { + mPtr->flags &= ~(PUBLIC_METHOD | TRUE_PRIVATE_METHOD); + isNew = 1; + } + return isNew; +} + +// Make the table of methods in the instance if it doesn't already exist. +static inline void +InitMethodTable( + Object *oPtr) +{ + if (!oPtr->methodsPtr) { + oPtr->methodsPtr = (Tcl_HashTable *) Tcl_Alloc(sizeof(Tcl_HashTable)); + Tcl_InitObjHashTable(oPtr->methodsPtr); + oPtr->flags &= ~USE_CLASS_CACHE; + } +} + +static int +ExportInstanceMethod( + Object *oPtr, + Tcl_Obj *namePtr) +{ + InitMethodTable(oPtr); + + int isNew; + Method *mPtr = GetOrCreateMethod(oPtr->methodsPtr, namePtr, &isNew); + if (isNew || !(mPtr->flags & (PUBLIC_METHOD | PRIVATE_METHOD))) { + mPtr->flags |= PUBLIC_METHOD; + mPtr->flags &= ~TRUE_PRIVATE_METHOD; + isNew = 1; + } + return isNew; +} + +static int +UnexportInstanceMethod( + Object *oPtr, + Tcl_Obj *namePtr) +{ + InitMethodTable(oPtr); + + int isNew; + Method *mPtr = GetOrCreateMethod(oPtr->methodsPtr, namePtr, &isNew); + if (isNew || mPtr->flags & (PUBLIC_METHOD | TRUE_PRIVATE_METHOD)) { + mPtr->flags &= ~(PUBLIC_METHOD | TRUE_PRIVATE_METHOD); + isNew = 1; + } + return isNew; +} + +/* + * ---------------------------------------------------------------------- + * * TclOODefineObjCmd -- * * Implementation of the "oo::define" command. Works by effectively doing @@ -1938,22 +2052,18 @@ TclOODefineExportObjCmd( Tcl_Obj *const *objv) { int isInstanceExport = (clientData != NULL); - Object *oPtr; - Method *mPtr; - Tcl_HashEntry *hPtr; - Class *clsPtr; - int i, isNew, changed = 0; + int i, changed = 0; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?"); return TCL_ERROR; } - oPtr = (Object *) TclOOGetDefineCmdContext(interp); + Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); if (oPtr == NULL) { return TCL_ERROR; } - clsPtr = oPtr->classPtr; + Class *clsPtr = oPtr->classPtr; if (!isInstanceExport && !clsPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "attempt to misuse API", TCL_AUTO_LENGTH)); @@ -1972,33 +2082,9 @@ TclOODefineExportObjCmd( */ if (isInstanceExport) { - if (!oPtr->methodsPtr) { - oPtr->methodsPtr = (Tcl_HashTable *) - Tcl_Alloc(sizeof(Tcl_HashTable)); - Tcl_InitObjHashTable(oPtr->methodsPtr); - oPtr->flags &= ~USE_CLASS_CACHE; - } - hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, objv[i], - &isNew); + changed |= ExportInstanceMethod(oPtr, objv[i]); } else { - hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, objv[i], - &isNew); - } - - if (isNew) { - mPtr = (Method *) Tcl_Alloc(sizeof(Method)); - memset(mPtr, 0, sizeof(Method)); - mPtr->refCount = 1; - mPtr->namePtr = objv[i]; - Tcl_IncrRefCount(objv[i]); - Tcl_SetHashValue(hPtr, mPtr); - } else { - mPtr = (Method *) Tcl_GetHashValue(hPtr); - } - if (isNew || !(mPtr->flags & (PUBLIC_METHOD | PRIVATE_METHOD))) { - mPtr->flags |= PUBLIC_METHOD; - mPtr->flags &= ~TRUE_PRIVATE_METHOD; - changed = 1; + changed |= ExportMethod(clsPtr, objv[i]); } } @@ -2098,30 +2184,30 @@ TclOODefineInitialiseObjCmd( int objc, Tcl_Obj *const *objv) { - Tcl_Object object; - Tcl_Obj *lambdaWords[3], *applyArgs[2]; - int result; - if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "body"); return TCL_ERROR; } - /* Build the lambda */ - object = TclOOGetDefineCmdContext(interp); + // Build the lambda + Tcl_Object object = TclOOGetDefineCmdContext(interp); if (object == NULL) { return TCL_ERROR; } - lambdaWords[0] = Tcl_NewObj(); - lambdaWords[1] = objv[1]; - lambdaWords[2] = TclNewNamespaceObj(Tcl_GetObjectNamespace(object)); + Tcl_Obj *lambdaWords[] = { + Tcl_NewObj(), + objv[1], + TclNewNamespaceObj(Tcl_GetObjectNamespace(object)) + }; - /* Delegate to [apply] to run it */ - applyArgs[0] = Tcl_NewStringObj("apply", -1); - applyArgs[1] = Tcl_NewListObj(3, lambdaWords); + // Delegate to [apply] to run it + Tcl_Obj *applyArgs[] = { + Tcl_NewStringObj("apply", -1), + Tcl_NewListObj(3, lambdaWords) + }; Tcl_IncrRefCount(applyArgs[0]); Tcl_IncrRefCount(applyArgs[1]); - result = Tcl_ApplyObjCmd(NULL, interp, 2, applyArgs); + int result = Tcl_ApplyObjCmd(NULL, interp, 2, applyArgs); Tcl_DecrRefCount(applyArgs[0]); Tcl_DecrRefCount(applyArgs[1]); return result; @@ -2243,32 +2329,23 @@ TclOODefineClassMethodObjCmd( int objc, Tcl_Obj *const *objv) { - Class *clsPtr; - int isPublic; - Tcl_Obj *forwardArgs[2], *prefixObj; - Method *mPtr; - if (objc != 2 && objc != 4) { Tcl_WrongNumArgs(interp, 1, objv, "name ?args body?"); return TCL_ERROR; } - clsPtr = TclOOGetClassDefineCmdContext(interp); + Class *clsPtr = TclOOGetClassDefineCmdContext(interp); if (!clsPtr) { return TCL_ERROR; } - isPublic = Tcl_StringMatch(TclGetString(objv[1]), PUBLIC_PATTERN) + int isPublic = Tcl_StringMatch(TclGetString(objv[1]), PUBLIC_PATTERN) ? PUBLIC_METHOD : 0; - /* - * Create the method on the delegate class if the caller gave arguments - * and body. - */ + // Create the method on the delegate class if the caller gave arguments and body if (objc == 4) { Tcl_Obj *delegateName = Tcl_ObjPrintf("%s:: oo ::delegate", clsPtr->thisPtr->namespacePtr->fullName); Class *delegatePtr = TclOOGetClassFromObj(interp, delegateName); - Tcl_DecrRefCount(delegateName); if (!delegatePtr) { return TCL_ERROR; @@ -2282,14 +2359,17 @@ TclOODefineClassMethodObjCmd( } } - /* Make the connection to the delegate by forwarding */ + // Make the connection to the delegate by forwarding if (IsPrivateDefine(interp)) { isPublic = TRUE_PRIVATE_METHOD; } - forwardArgs[0] = Tcl_NewStringObj("myclass", -1); - forwardArgs[1] = objv[1]; - prefixObj = Tcl_NewListObj(2, forwardArgs); - mPtr = TclOONewForwardMethod(interp, clsPtr, isPublic, objv[1], prefixObj); + Tcl_Obj *forwardArgs[] = { + Tcl_NewStringObj("myclass", -1), + objv[1] + }; + Tcl_Obj *prefixObj = Tcl_NewListObj(2, forwardArgs); + Method *mPtr = TclOONewForwardMethod(interp, clsPtr, isPublic, + objv[1], prefixObj); if (mPtr == NULL) { Tcl_DecrRefCount(prefixObj); return TCL_ERROR; @@ -2374,10 +2454,8 @@ TclOODefineUnexportObjCmd( { int isInstanceUnexport = (clientData != NULL); Object *oPtr; - Method *mPtr; - Tcl_HashEntry *hPtr; Class *clsPtr; - int i, isNew, changed = 0; + int i, changed = 0; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?"); @@ -2397,42 +2475,10 @@ TclOODefineUnexportObjCmd( } for (i = 1; i < objc; i++) { - /* - * Unexporting is done by removing the PUBLIC_METHOD flag from the - * method record. If there is no such method in this object or class - * (i.e. the method comes from something inherited from or that we're - * an instance of) then we put in a blank record without that flag; - * such records are skipped over by the call chain engine *except* for - * their flags member. - */ - if (isInstanceUnexport) { - if (!oPtr->methodsPtr) { - oPtr->methodsPtr = (Tcl_HashTable *) - Tcl_Alloc(sizeof(Tcl_HashTable)); - Tcl_InitObjHashTable(oPtr->methodsPtr); - oPtr->flags &= ~USE_CLASS_CACHE; - } - hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, objv[i], - &isNew); + changed |= UnexportInstanceMethod(oPtr, objv[i]); } else { - hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, objv[i], - &isNew); - } - - if (isNew) { - mPtr = (Method *) Tcl_Alloc(sizeof(Method)); - memset(mPtr, 0, sizeof(Method)); - mPtr->refCount = 1; - mPtr->namePtr = objv[i]; - Tcl_IncrRefCount(objv[i]); - Tcl_SetHashValue(hPtr, mPtr); - } else { - mPtr = (Method *) Tcl_GetHashValue(hPtr); - } - if (isNew || mPtr->flags & (PUBLIC_METHOD | TRUE_PRIVATE_METHOD)) { - mPtr->flags &= ~(PUBLIC_METHOD | TRUE_PRIVATE_METHOD); - changed = 1; + changed |= UnexportMethod(clsPtr, objv[i]); } } @@ -2510,8 +2556,9 @@ Tcl_ClassSetDestructor( * * TclOODefineSlots -- * - * Create the "::oo::Slot" class and its standard instances. Class - * definition is empty at the stage (added by scripting). + * Create the "::oo::Slot" class and its standard instances. These are + * basically lists at the low level of TclOO; this provides a more + * consistent interface to them. * * ---------------------------------------------------------------------- */ @@ -2523,26 +2570,36 @@ TclOODefineSlots( Tcl_Interp *interp = fPtr->interp; Tcl_Object object = Tcl_NewObjectInstance(interp, (Tcl_Class) fPtr->classCls, "::oo::Slot", NULL, TCL_INDEX_NONE, NULL, 0); - Tcl_Class slotCls; - const DeclaredSlotMethod *smPtr; - const DeclaredSlot *slotPtr; if (object == NULL) { return TCL_ERROR; } - slotCls = (Tcl_Class) ((Object *) object)->classPtr; + Tcl_Class slotCls = (Tcl_Class) ((Object *) object)->classPtr; if (slotCls == NULL) { return TCL_ERROR; } - for (smPtr = slotMethods; smPtr->name; smPtr++) { + for (const DeclaredSlotMethod *smPtr = slotMethods; smPtr->name; smPtr++) { Tcl_Obj *name = Tcl_NewStringObj(smPtr->name, -1); Tcl_NewMethod(interp, slotCls, name, smPtr->flags, &smPtr->implType, NULL); Tcl_BounceRefCount(name); } - for (slotPtr = slots ; slotPtr->name ; slotPtr++) { + // If a slot can't figure out what method to call directly, it uses + // --default-operation. That defaults to -append; we set that here. + Tcl_Obj *defaults[] = { + fPtr->myName, + Tcl_NewStringObj("-append", TCL_AUTO_LENGTH) + }; + TclOONewForwardMethod(interp, (Class *) slotCls, 0, + fPtr->slotDefOpName, Tcl_NewListObj(2, defaults)); + + // Hide the destroy method. (We're definitely taking a ref to the name.) + UnexportMethod((Class *) slotCls, + Tcl_NewStringObj("destroy", TCL_AUTO_LENGTH)); + + for (const DeclaredSlot *slotPtr = slots ; slotPtr->name ; slotPtr++) { Tcl_Object slotObject = Tcl_NewObjectInstance(interp, slotCls, slotPtr->name, NULL, TCL_INDEX_NONE, NULL, 0); @@ -2557,6 +2614,14 @@ TclOODefineSlots( TclNewInstanceMethod(interp, slotObject, fPtr->slotResolveName, 0, &slotPtr->resolverType, NULL); } + if (slotPtr->defaultOp) { + Tcl_Obj *slotDefaults[] = { + fPtr->myName, + Tcl_NewStringObj(slotPtr->defaultOp, TCL_AUTO_LENGTH) + }; + TclOONewForwardInstanceMethod(interp, (Object *) slotObject, 0, + fPtr->slotDefOpName, Tcl_NewListObj(2, slotDefaults)); + } } return TCL_OK; } @@ -2573,52 +2638,51 @@ TclOODefineSlots( * ---------------------------------------------------------------------- */ -/* Call [$slot Get] to retrieve the list of contents of the slot */ +// Call [$slot Get] to retrieve the list of contents of the slot static inline Tcl_Obj * CallSlotGet( Tcl_Interp *interp, Object *slot) { - Tcl_Obj *getArgs[2]; - int code; - - getArgs[0] = slot->fPtr->myName; - getArgs[1] = slot->fPtr->slotGetName; - code = TclOOPrivateObjectCmd(slot, interp, 2, getArgs); + Tcl_Obj *getArgs[] = { + slot->fPtr->myName, + slot->fPtr->slotGetName + }; + int code = TclOOPrivateObjectCmd(slot, interp, 2, getArgs); if (code != TCL_OK) { return NULL; } return Tcl_GetObjResult(interp); } -/* Call [$slot Set $list] to set the list of contents of the slot */ +// Call [$slot Set $list] to set the list of contents of the slot static inline int CallSlotSet( Tcl_Interp *interp, Object *slot, Tcl_Obj *list) { - Tcl_Obj *setArgs[3]; - setArgs[0] = slot->fPtr->myName; - setArgs[1] = slot->fPtr->slotSetName; - setArgs[2] = list; + Tcl_Obj *setArgs[] = { + slot->fPtr->myName, + slot->fPtr->slotSetName, + list + }; return TclOOPrivateObjectCmd(slot, interp, 3, setArgs); } -/* Call [$slot Resolve $item] to convert a slot item into canonical form */ +// Call [$slot Resolve $item] to convert a slot item into canonical form static inline Tcl_Obj * CallSlotResolve( Tcl_Interp *interp, Object *slot, Tcl_Obj *item) { - Tcl_Obj *resolveArgs[3]; - int code; - - resolveArgs[0] = slot->fPtr->myName; - resolveArgs[1] = slot->fPtr->slotResolveName; - resolveArgs[2] = item; - code = TclOOPrivateObjectCmd(slot, interp, 3, resolveArgs); + Tcl_Obj *resolveArgs[] = { + slot->fPtr->myName, + slot->fPtr->slotResolveName, + item + }; + int code = TclOOPrivateObjectCmd(slot, interp, 3, resolveArgs); if (code != TCL_OK) { return NULL; } @@ -2634,10 +2698,7 @@ ResolveAll( { Tcl_Obj **resolvedItems = (Tcl_Obj **) TclStackAlloc(interp, sizeof(Tcl_Obj *) * objc); - Tcl_Obj *resolvedList; - int i; - - for (i = 0; i < objc; i++) { + for (int i = 0; i < objc; i++) { resolvedItems[i] = CallSlotResolve(interp, slot, objv[i]); if (resolvedItems[i] == NULL) { for (int j = 0; j < i; j++) { @@ -2649,8 +2710,8 @@ ResolveAll( Tcl_IncrRefCount(resolvedItems[i]); Tcl_ResetResult(interp); } - resolvedList = Tcl_NewListObj(objc, resolvedItems); - for (i = 0; i < objc; i++) { + Tcl_Obj *resolvedList = Tcl_NewListObj(objc, resolvedItems); + for (int i = 0; i < objc; i++) { TclDecrRefCount(resolvedItems[i]); } TclStackFree(interp, (void *) resolvedItems); @@ -2675,21 +2736,19 @@ Slot_Append( Tcl_Obj *const *objv) { Object *oPtr = (Object *) Tcl_ObjectContextObject(context); - int skip = Tcl_ObjectContextSkippedArgs(context), code; - Tcl_Obj *resolved, *list; - + int skip = Tcl_ObjectContextSkippedArgs(context); if (skip == objc) { return TCL_OK; } - /* Resolve all values */ - resolved = ResolveAll(interp, oPtr, objc - skip, objv + skip); + // Resolve all values + Tcl_Obj *resolved = ResolveAll(interp, oPtr, objc - skip, objv + skip); if (resolved == NULL) { return TCL_ERROR; } - /* Get slot contents; store in list */ - list = CallSlotGet(interp, oPtr); + // Get slot contents; store in list + Tcl_Obj *list = CallSlotGet(interp, oPtr); if (list == NULL) { Tcl_DecrRefCount(resolved); return TCL_ERROR; @@ -2697,7 +2756,7 @@ Slot_Append( Tcl_IncrRefCount(list); Tcl_ResetResult(interp); - /* Append */ + // Append if (Tcl_IsShared(list)) { Tcl_Obj *dup = Tcl_DuplicateObj(list); Tcl_IncrRefCount(dup); @@ -2711,8 +2770,8 @@ Slot_Append( } Tcl_DecrRefCount(resolved); - /* Set slot contents */ - code = CallSlotSet(interp, oPtr, list); + // Set slot contents + int code = CallSlotSet(interp, oPtr, list); Tcl_DecrRefCount(list); return code; } @@ -2735,23 +2794,19 @@ Slot_AppendNew( Tcl_Obj *const *objv) { Object *oPtr = (Object *) Tcl_ObjectContextObject(context); - int skip = Tcl_ObjectContextSkippedArgs(context), code, isNew; - Tcl_Obj *resolved, *list, **listv; - Tcl_Size listc, i; - Tcl_HashTable unique; - + int skip = Tcl_ObjectContextSkippedArgs(context); if (skip == objc) { return TCL_OK; } - /* Resolve all values */ - resolved = ResolveAll(interp, oPtr, objc - skip, objv + skip); + // Resolve all values + Tcl_Obj *resolved = ResolveAll(interp, oPtr, objc - skip, objv + skip); if (resolved == NULL) { return TCL_ERROR; } - /* Get slot contents; store in list */ - list = CallSlotGet(interp, oPtr); + // Get slot contents; store in list + Tcl_Obj *list = CallSlotGet(interp, oPtr); if (list == NULL) { Tcl_DecrRefCount(resolved); return TCL_ERROR; @@ -2759,18 +2814,21 @@ Slot_AppendNew( Tcl_IncrRefCount(list); Tcl_ResetResult(interp); - /* Prepare a set of items in the list to set */ + // Prepare a set of items in the list to set + Tcl_Size listc; + Tcl_Obj **listv; if (TclListObjGetElements(interp, list, &listc, &listv) != TCL_OK) { Tcl_DecrRefCount(list); Tcl_DecrRefCount(resolved); return TCL_ERROR; } + Tcl_HashTable unique; Tcl_InitObjHashTable(&unique); - for (i=0 ; i<listc; i++) { - Tcl_CreateHashEntry(&unique, listv[i], &isNew); + for (Tcl_Size i=0 ; i<listc; i++) { + Tcl_CreateHashEntry(&unique, listv[i], NULL); } - /* Append the new items if they're not already there */ + // Append the new items if they're not already there if (Tcl_IsShared(list)) { Tcl_Obj *dup = Tcl_DuplicateObj(list); Tcl_IncrRefCount(dup); @@ -2778,7 +2836,8 @@ Slot_AppendNew( list = dup; } TclListObjGetElements(NULL, resolved, &listc, &listv); - for (i=0 ; i<listc; i++) { + for (Tcl_Size i=0 ; i<listc; i++) { + int isNew; Tcl_CreateHashEntry(&unique, listv[i], &isNew); if (isNew) { Tcl_ListObjAppendElement(interp, list, listv[i]); @@ -2787,8 +2846,8 @@ Slot_AppendNew( Tcl_DecrRefCount(resolved); Tcl_DeleteHashTable(&unique); - /* Set slot contents */ - code = CallSlotSet(interp, oPtr, list); + // Set slot contents + int code = CallSlotSet(interp, oPtr, list); Tcl_DecrRefCount(list); return code; } @@ -2811,16 +2870,14 @@ Slot_Clear( Tcl_Obj *const *objv) { Object *oPtr = (Object *) Tcl_ObjectContextObject(context); - int skip = Tcl_ObjectContextSkippedArgs(context), code; - Tcl_Obj *list; - + int skip = Tcl_ObjectContextSkippedArgs(context); if (skip != objc) { Tcl_WrongNumArgs(interp, skip, objv, NULL); return TCL_ERROR; } - list = Tcl_NewObj(); + Tcl_Obj *list = Tcl_NewObj(); Tcl_IncrRefCount(list); - code = CallSlotSet(interp, oPtr, list); + int code = CallSlotSet(interp, oPtr, list); Tcl_DecrRefCount(list); return code; } @@ -2843,21 +2900,20 @@ Slot_Prepend( Tcl_Obj *const *objv) { Object *oPtr = (Object *) Tcl_ObjectContextObject(context); - int skip = Tcl_ObjectContextSkippedArgs(context), code; - Tcl_Obj *list, *oldList; + int skip = Tcl_ObjectContextSkippedArgs(context); if (skip == objc) { return TCL_OK; } - /* Resolve all values */ - list = ResolveAll(interp, oPtr, objc - skip, objv + skip); + // Resolve all values + Tcl_Obj *list = ResolveAll(interp, oPtr, objc - skip, objv + skip); if (list == NULL) { return TCL_ERROR; } Tcl_IncrRefCount(list); - /* Get slot contents and append to list */ - oldList = CallSlotGet(interp, oPtr); + // Get slot contents and append to list + Tcl_Obj *oldList = CallSlotGet(interp, oPtr); if (oldList == NULL) { Tcl_DecrRefCount(list); return TCL_ERROR; @@ -2865,8 +2921,8 @@ Slot_Prepend( Tcl_ListObjAppendList(NULL, list, oldList); Tcl_ResetResult(interp); - /* Set slot contents */ - code = CallSlotSet(interp, oPtr, list); + // Set slot contents + int code = CallSlotSet(interp, oPtr, list); Tcl_DecrRefCount(list); return code; } @@ -2889,23 +2945,19 @@ Slot_Remove( Tcl_Obj *const *objv) { Object *oPtr = (Object *) Tcl_ObjectContextObject(context); - int skip = Tcl_ObjectContextSkippedArgs(context), code, isNew; - Tcl_Size listc, i; - Tcl_Obj *resolved, *oldList, *newList, **listv; - Tcl_HashTable removeSet; - + int skip = Tcl_ObjectContextSkippedArgs(context); if (skip == objc) { return TCL_OK; } - /* Resolve all values */ - resolved = ResolveAll(interp, oPtr, objc - skip, objv + skip); + // Resolve all values + Tcl_Obj *resolved = ResolveAll(interp, oPtr, objc - skip, objv + skip); if (resolved == NULL) { return TCL_ERROR; } - /* Get slot contents; store in list */ - oldList = CallSlotGet(interp, oPtr); + // Get slot contents; store in list + Tcl_Obj *oldList = CallSlotGet(interp, oPtr); if (oldList == NULL) { Tcl_DecrRefCount(resolved); return TCL_ERROR; @@ -2913,22 +2965,25 @@ Slot_Remove( Tcl_IncrRefCount(oldList); Tcl_ResetResult(interp); - /* Prepare a set of items in the list to remove */ + // Prepare a set of items in the list to remove + Tcl_Size listc; + Tcl_Obj **listv; TclListObjGetElements(NULL, resolved, &listc, &listv); + Tcl_HashTable removeSet; Tcl_InitObjHashTable(&removeSet); - for (i=0 ; i<listc; i++) { - Tcl_CreateHashEntry(&removeSet, listv[i], &isNew); + for (Tcl_Size i=0 ; i<listc; i++) { + Tcl_CreateHashEntry(&removeSet, listv[i], NULL); } Tcl_DecrRefCount(resolved); - /* Append the new items from the old items if they're not in the remove set */ + // Append the new items from the old items if they're not in the remove set if (TclListObjGetElements(interp, oldList, &listc, &listv) != TCL_OK) { Tcl_DecrRefCount(oldList); Tcl_DeleteHashTable(&removeSet); return TCL_ERROR; } - newList = Tcl_NewObj(); - for (i=0 ; i<listc; i++) { + Tcl_Obj *newList = Tcl_NewObj(); + for (Tcl_Size i=0 ; i<listc; i++) { if (Tcl_FindHashEntry(&removeSet, listv[i]) == NULL) { Tcl_ListObjAppendElement(NULL, newList, listv[i]); } @@ -2936,9 +2991,9 @@ Slot_Remove( Tcl_DecrRefCount(oldList); Tcl_DeleteHashTable(&removeSet); - /* Set slot contents */ + // Set slot contents Tcl_IncrRefCount(newList); - code = CallSlotSet(interp, oPtr, newList); + int code = CallSlotSet(interp, oPtr, newList); Tcl_DecrRefCount(newList); return code; } @@ -2988,10 +3043,10 @@ Slot_Set( Tcl_Obj *const *objv) { Object *oPtr = (Object *) Tcl_ObjectContextObject(context); - int skip = Tcl_ObjectContextSkippedArgs(context), code; + int skip = Tcl_ObjectContextSkippedArgs(context); Tcl_Obj *list; - /* Resolve all values */ + // Resolve all values if (skip == objc) { list = Tcl_NewObj(); } else { @@ -3002,8 +3057,8 @@ Slot_Set( } Tcl_IncrRefCount(list); - /* Set slot contents */ - code = CallSlotSet(interp, oPtr, list); + // Set slot contents + int code = CallSlotSet(interp, oPtr, list); Tcl_DecrRefCount(list); return code; } @@ -3051,11 +3106,12 @@ Slot_Unknown( Tcl_Obj *const *objv) { Object *oPtr = (Object *) Tcl_ObjectContextObject(context); - int skip = Tcl_ObjectContextSkippedArgs(context), code; + int skip = Tcl_ObjectContextSkippedArgs(context); if (skip >= objc) { - Tcl_Obj *args[2]; - args[0] = oPtr->fPtr->myName; - args[1] = oPtr->fPtr->slotDefOpName; + Tcl_Obj *args[] = { + oPtr->fPtr->myName, + oPtr->fPtr->slotDefOpName + }; return TclOOPrivateObjectCmd(oPtr, interp, 2, args); } else if (TclGetString(objv[skip])[0] != '-') { Tcl_Obj **args = (Tcl_Obj **) TclStackAlloc(interp, @@ -3063,7 +3119,7 @@ Slot_Unknown( args[0] = oPtr->fPtr->myName; args[1] = oPtr->fPtr->slotDefOpName; memcpy(args+2, objv+skip, sizeof(Tcl_Obj*) * (objc - skip)); - code = TclOOPrivateObjectCmd(oPtr, interp, objc - skip + 2, args); + int code = TclOOPrivateObjectCmd(oPtr, interp, objc - skip + 2, args); TclStackFree(interp, args); return code; } @@ -3178,7 +3234,6 @@ ClassMixin_Get( } Tcl_SetObjResult(interp, resultObj); return TCL_OK; - } static int @@ -3803,7 +3858,7 @@ ResolveClass( int objc, Tcl_Obj *const *objv) { - int idx = Tcl_ObjectContextSkippedArgs(context); + Tcl_Size idx = Tcl_ObjectContextSkippedArgs(context); Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); Class *clsPtr; diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c index bec931a..42663ae 100644 --- a/generic/tclOOInfo.c +++ b/generic/tclOOInfo.c @@ -51,7 +51,7 @@ static Tcl_ObjCmdProc InfoClassVariablesCmd; static const EnsembleImplMap infoObjectCmds[] = { {"call", InfoObjectCallCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"class", InfoObjectClassCmd, TclCompileInfoObjectClassCmd, NULL, NULL, 0}, - {"creationid", InfoObjectIdCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"creationid", InfoObjectIdCmd, TclCompileInfoObjectCreationIdCmd, NULL, NULL, 0}, {"definition", InfoObjectDefnCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"filters", InfoObjectFiltersCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"forward", InfoObjectForwardCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, @@ -88,22 +88,39 @@ static const EnsembleImplMap infoClassCmds[] = { {"variables", InfoClassVariablesCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, {NULL, NULL, NULL, NULL, NULL, 0} }; - /* * ---------------------------------------------------------------------- * - * LocalVarName -- + * DescribeMethodArgs -- * - * Get the name of a local variable (especially a method argument) as a - * Tcl value. + * Generate the descriptor for the arguments to a method (including a + * constructor, usually). * * ---------------------------------------------------------------------- */ static inline Tcl_Obj * -LocalVarName( - CompiledLocal *localPtr) +DescribeMethodArgs( + Proc *procPtr) { - return Tcl_NewStringObj(localPtr->name, TCL_AUTO_LENGTH); + Tcl_Obj *argObjList; + CompiledLocal *localPtr; + + TclNewObj(argObjList); + for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL; + localPtr=localPtr->nextPtr) { + if (TclIsVarArgument(localPtr)) { + Tcl_Obj *argObj; + + TclNewObj(argObj); + Tcl_ListObjAppendElement(NULL, argObj, Tcl_NewStringObj( + localPtr->name, localPtr->nameLength)); + if (localPtr->defValuePtr != NULL) { + Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr); + } + Tcl_ListObjAppendElement(NULL, argObjList, argObj); + } + } + return argObjList; } /* @@ -252,7 +269,6 @@ InfoObjectDefnCmd( Object *oPtr; Tcl_HashEntry *hPtr; Proc *procPtr; - CompiledLocal *localPtr; Tcl_Obj *resultObjs[2]; if (objc != 3) { @@ -281,20 +297,7 @@ InfoObjectDefnCmd( * We now have the method to describe the definition of. */ - TclNewObj(resultObjs[0]); - for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL; - localPtr=localPtr->nextPtr) { - if (TclIsVarArgument(localPtr)) { - Tcl_Obj *argObj; - - TclNewObj(argObj); - Tcl_ListObjAppendElement(NULL, argObj, LocalVarName(localPtr)); - if (localPtr->defValuePtr != NULL) { - Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr); - } - Tcl_ListObjAppendElement(NULL, resultObjs[0], argObj); - } - } + resultObjs[0] = DescribeMethodArgs(procPtr); resultObjs[1] = TclOOGetMethodBody((Method *) Tcl_GetHashValue(hPtr)); Tcl_SetObjResult(interp, Tcl_NewListObj(2, resultObjs)); return TCL_OK; @@ -1001,7 +1004,6 @@ InfoClassConstrCmd( Tcl_Obj *const objv[]) { Proc *procPtr; - CompiledLocal *localPtr; Tcl_Obj *resultObjs[2]; Class *clsPtr; @@ -1025,20 +1027,7 @@ InfoClassConstrCmd( return TCL_ERROR; } - TclNewObj(resultObjs[0]); - for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL; - localPtr=localPtr->nextPtr) { - if (TclIsVarArgument(localPtr)) { - Tcl_Obj *argObj; - - TclNewObj(argObj); - Tcl_ListObjAppendElement(NULL, argObj, LocalVarName(localPtr)); - if (localPtr->defValuePtr != NULL) { - Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr); - } - Tcl_ListObjAppendElement(NULL, resultObjs[0], argObj); - } - } + resultObjs[0] = DescribeMethodArgs(procPtr); resultObjs[1] = TclOOGetMethodBody(clsPtr->constructorPtr); Tcl_SetObjResult(interp, Tcl_NewListObj(2, resultObjs)); return TCL_OK; @@ -1063,7 +1052,6 @@ InfoClassDefnCmd( { Tcl_HashEntry *hPtr; Proc *procPtr; - CompiledLocal *localPtr; Tcl_Obj *resultObjs[2]; Class *clsPtr; @@ -1093,20 +1081,7 @@ InfoClassDefnCmd( return TCL_ERROR; } - TclNewObj(resultObjs[0]); - for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL; - localPtr=localPtr->nextPtr) { - if (TclIsVarArgument(localPtr)) { - Tcl_Obj *argObj; - - TclNewObj(argObj); - Tcl_ListObjAppendElement(NULL, argObj, LocalVarName(localPtr)); - if (localPtr->defValuePtr != NULL) { - Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr); - } - Tcl_ListObjAppendElement(NULL, resultObjs[0], argObj); - } - } + resultObjs[0] = DescribeMethodArgs(procPtr); resultObjs[1] = TclOOGetMethodBody((Method *) Tcl_GetHashValue(hPtr)); Tcl_SetObjResult(interp, Tcl_NewListObj(2, resultObjs)); return TCL_OK; diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index 70b4a32..777c7fa 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -202,7 +202,7 @@ struct PropertyStorage { * exposed by this object or class (in its * stereotypical instances). Contains a sorted * unique list if not NULL. */ - int epoch; /* The epoch that the caches are valid for. */ + Tcl_Size epoch; /* The epoch that the caches are valid for. */ }; /* @@ -260,7 +260,7 @@ struct Object { enum ObjectFlags { OBJECT_DESTRUCTING = 1, /* Indicates that an object is being or has - * been destroyed */ + * been destroyed. */ DESTRUCTOR_CALLED = 2, /* Indicates that evaluation of destructor * script for the object has began */ ROOT_OBJECT = 0x1000, /* Flag to say that this object is the root of @@ -576,6 +576,7 @@ MODULE_SCOPE Object * TclNewObjectInstanceCommon(Tcl_Interp *interp, const char *nsNameStr); MODULE_SCOPE int TclOODecrRefCount(Object *oPtr); MODULE_SCOPE int TclOOObjectDestroyed(Object *oPtr); +MODULE_SCOPE const char *TclOOContextTypeName(CallContext *contextPtr); MODULE_SCOPE int TclOODefineSlots(Foundation *fPtr); MODULE_SCOPE void TclOODeleteChain(CallChain *callPtr); MODULE_SCOPE void TclOODeleteChainCache(Tcl_HashTable *tablePtr); @@ -600,7 +601,7 @@ MODULE_SCOPE Proc * TclOOGetProcFromMethod(Method *mPtr); MODULE_SCOPE Tcl_Obj * TclOOGetMethodBody(Method *mPtr); MODULE_SCOPE size_t TclOOGetSortedClassMethodList(Class *clsPtr, int flags, const char ***stringsPtr); -MODULE_SCOPE int TclOOGetSortedMethodList(Object *oPtr, +MODULE_SCOPE Tcl_Size TclOOGetSortedMethodList(Object *oPtr, Object *contextObj, Class *contextCls, int flags, const char ***stringsPtr); MODULE_SCOPE int TclOOInit(Tcl_Interp *interp); @@ -666,7 +667,7 @@ MODULE_SCOPE void TclOORegisterInstanceProperty(Object *oPtr, */ #define FOREACH(var,ary) \ - for(i=0 ; i<(ary).num; i++) if ((ary).list[i] == NULL) { \ + for (i=0 ; i<(ary).num; i++) if ((ary).list[i] == NULL) { \ continue; \ } else if ((var) = (ary).list[i], 1) @@ -678,7 +679,7 @@ MODULE_SCOPE void TclOORegisterInstanceProperty(Object *oPtr, */ #define FOREACH_STRUCT(var,ary) \ - if (i=0, (ary).num>0) for(; var=&((ary).list[i]), i<(ary).num; i++) + if (i=0, (ary).num>0) for (; var=&((ary).list[i]), i<(ary).num; i++) /* * Convenience macros for iterating through hash tables. FOREACH_HASH_DECLS @@ -691,16 +692,16 @@ MODULE_SCOPE void TclOORegisterInstanceProperty(Object *oPtr, #define FOREACH_HASH_DECLS \ Tcl_HashEntry *hPtr;Tcl_HashSearch search #define FOREACH_HASH(key, val, tablePtr) \ - for(hPtr = Tcl_FirstHashEntry((tablePtr), &search); hPtr != NULL ? \ + for (hPtr = Tcl_FirstHashEntry((tablePtr), &search); hPtr != NULL ? \ (*(void **)&(key) = Tcl_GetHashKey((tablePtr), hPtr), \ *(void **)&(val) = Tcl_GetHashValue(hPtr), 1) : 0; \ hPtr = Tcl_NextHashEntry(&search)) #define FOREACH_HASH_KEY(key, tablePtr) \ - for(hPtr = Tcl_FirstHashEntry((tablePtr), &search); hPtr != NULL ? \ + for (hPtr = Tcl_FirstHashEntry((tablePtr), &search); hPtr != NULL ? \ (*(void **)&(key) = Tcl_GetHashKey((tablePtr), hPtr), 1) : 0; \ hPtr = Tcl_NextHashEntry(&search)) #define FOREACH_HASH_VALUE(val, tablePtr) \ - for(hPtr = Tcl_FirstHashEntry((tablePtr), &search); hPtr != NULL ? \ + for (hPtr = Tcl_FirstHashEntry((tablePtr), &search); hPtr != NULL ? \ (*(void **)&(val) = Tcl_GetHashValue(hPtr), 1) : 0; \ hPtr = Tcl_NextHashEntry(&search)) diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index 2c06822..4a7e818 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -555,13 +555,12 @@ InitCmdFrame( if (context.line && context.nline > 1 && (context.line[context.nline - 1] >= 0)) { - int isNew; CmdFrame *cfPtr = (CmdFrame *) Tcl_Alloc(sizeof(CmdFrame)); Tcl_HashEntry *hPtr; cfPtr->level = -1; cfPtr->type = context.type; - cfPtr->line = (Tcl_Size *) Tcl_Alloc(sizeof(Tcl_Size)); + cfPtr->line = (int *) Tcl_Alloc(sizeof(int)); cfPtr->line[0] = context.line[context.nline - 1]; cfPtr->nline = 1; cfPtr->framePtr = NULL; @@ -574,7 +573,7 @@ InitCmdFrame( cfPtr->len = 0; hPtr = Tcl_CreateHashEntry(iPtr->linePBodyPtr, - procPtr, &isNew); + procPtr, NULL); Tcl_SetHashValue(hPtr, cfPtr); } @@ -774,8 +773,8 @@ TclOOMakeProcMethod2( InitCmdFrame(iPtr, procPtr); - return TclNewMethod( - (Tcl_Class) clsPtr, nameObj, flags, (const Tcl_MethodType *)typePtr, clientData); + return TclNewMethod((Tcl_Class) clsPtr, nameObj, flags, + (const Tcl_MethodType *)typePtr, clientData); } /* diff --git a/generic/tclOOProp.c b/generic/tclOOProp.c index 35c84e7..df67ca7 100644 --- a/generic/tclOOProp.c +++ b/generic/tclOOProp.c @@ -211,10 +211,10 @@ GetPropertyName( * We use a recursive call to look this up. */ - Tcl_InterpState foo = Tcl_SaveInterpState(interp, result); + Tcl_InterpState state = Tcl_SaveInterpState(interp, result); Tcl_Obj *otherName = GetPropertyName(interp, oPtr, flags ^ (GPN_WRITABLE | GPN_FALLING_BACK), namePtr, NULL); - result = Tcl_RestoreInterpState(interp, foo); + result = Tcl_RestoreInterpState(interp, state); if (otherName != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "property \"%s\" is %s only", @@ -542,18 +542,18 @@ FindClassProps( * property set. */ Tcl_HashTable *accumulator) /* Where to gather the names. */ { - int i, dummy; + int i; Tcl_Obj *propName; Class *mixin, *sup; tailRecurse: if (writable) { FOREACH(propName, clsPtr->properties.writable) { - Tcl_CreateHashEntry(accumulator, (void *) propName, &dummy); + Tcl_CreateHashEntry(accumulator, (void *) propName, NULL); } } else { FOREACH(propName, clsPtr->properties.readable) { - Tcl_CreateHashEntry(accumulator, (void *) propName, &dummy); + Tcl_CreateHashEntry(accumulator, (void *) propName, NULL); } } if (clsPtr->thisPtr->flags & ROOT_OBJECT) { @@ -593,17 +593,17 @@ FindObjectProps( * property set. */ Tcl_HashTable *accumulator) /* Where to gather the names. */ { - int i, dummy; + int i; Tcl_Obj *propName; Class *mixin; if (writable) { FOREACH(propName, oPtr->properties.writable) { - Tcl_CreateHashEntry(accumulator, (void *) propName, &dummy); + Tcl_CreateHashEntry(accumulator, (void *) propName, NULL); } } else { FOREACH(propName, oPtr->properties.readable) { - Tcl_CreateHashEntry(accumulator, (void *) propName, &dummy); + Tcl_CreateHashEntry(accumulator, (void *) propName, NULL); } } FOREACH(mixin, oPtr->mixins) { diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index 318a7ac..390b034 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -27,11 +27,6 @@ static const char *tclOOSetupScript = /* !BEGIN!: Do not edit below this line. */ "::namespace eval ::oo {\n" -"\tdefine Slot forward --default-operation my -append\n" -"\tdefine Slot unexport destroy\n" -"\tobjdefine define::superclass forward --default-operation my -set\n" -"\tobjdefine define::mixin forward --default-operation my -set\n" -"\tobjdefine objdefine::mixin forward --default-operation my -set\n" "\tdefine object method <cloned> -unexport {originObject} {\n" "\t\tforeach p [info procs [info object namespace $originObject]::*] {\n" "\t\t\tset args [info args $p]\n" @@ -77,24 +72,24 @@ static const char *tclOOSetupScript = "\t}\n" "\tclass create singleton\n" "\tdefine singleton superclass -set class\n" -"\tdefine singleton variable -set object\n" "\tdefine singleton unexport create createWithNamespace\n" "\tdefine singleton method new args {\n" +"\t\tvariable object\n" "\t\tif {![info exists object] || ![info object isa object $object]} {\n" "\t\t\tset object [next {*}$args]\n" -"\t\t\t::oo::objdefine $object {\n" -"\t\t\t\tmethod destroy {} {\n" -"\t\t\t\t\treturn -code error -errorcode {TCL OO SINGLETON} \\\n" -"\t\t\t\t\t\t\"may not destroy a singleton object\"\n" -"\t\t\t\t}\n" -"\t\t\t\tmethod <cloned> -unexport {originObject} {\n" -"\t\t\t\t\treturn -code error -errorcode {TCL OO SINGLETON} \\\n" -"\t\t\t\t\t\t\"may not clone a singleton object\"\n" -"\t\t\t\t}\n" -"\t\t\t}\n" +"\t\t\t::oo::objdefine $object mixin -prepend ::oo::SingletonInstance\n" "\t\t}\n" "\t\treturn $object\n" "\t}\n" +"\tclass create SingletonInstance\n" +"\tdefine SingletonInstance method destroy {} {\n" +"\t\treturn -code error -errorcode {TCL OO SINGLETON} \\\n" +"\t\t\t\"may not destroy a singleton object\"\n" +"\t}\n" +"\tdefine SingletonInstance method <cloned> -unexport {originObject} {\n" +"\t\treturn -code error -errorcode {TCL OO SINGLETON} \\\n" +"\t\t\t\"may not clone a singleton object\"\n" +"\t}\n" "\tclass create abstract\n" "\tdefine abstract superclass -set class\n" "\tdefine abstract unexport create createWithNamespace new\n" @@ -115,7 +110,7 @@ static const char *tclOOSetupScript = "\tclass create configurable\n" "\tdefine configurable superclass -set class\n" "\tdefine configurable constructor {{definitionScript \"\"}} {\n" -"\t\too::define [self] {mixin -append ::oo::configuresupport::configurable}\n" +"\t\t::oo::define [self] {mixin -append ::oo::configuresupport::configurable}\n" "\t\tnext $definitionScript\n" "\t}\n" "\tdefine configurable definitionnamespace -class configuresupport::configurableclass\n" diff --git a/generic/tclObj.c b/generic/tclObj.c index b84514e..f9fc83f 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -77,7 +77,7 @@ typedef struct { */ typedef struct { - Tcl_HashTable *lineCLPtr; /* This table remembers for each Tcl_Obj + Tcl_HashTable *lineCLPtr; /* This table remembers for each Tcl_Obj * generated by a call to the function * TclSubstTokens() from a literal text * where bs+nl sequences occurred in it, if @@ -145,13 +145,13 @@ typedef struct PendingObjData { #define ObjDeletionUnlock(contextPtr) ((contextPtr)->deletionCount--) #define ObjDeletePending(contextPtr) ((contextPtr)->deletionCount > 0) #define ObjOnStack(contextPtr) ((contextPtr)->deletionStack != NULL) -#define PushObjToDelete(contextPtr,objPtr) \ +#define PushObjToDelete(contextPtr, objPtr) \ /* The string rep is already invalidated so we can use the bytes value \ - * for our pointer chain: push onto the head of the stack. */ \ - (objPtr)->bytes = (char *) ((contextPtr)->deletionStack); \ + * for our pointer chain: push onto the head of the stack. */ \ + (objPtr)->bytes = (char *) ((contextPtr)->deletionStack); \ (contextPtr)->deletionStack = (objPtr) -#define PopObjToDelete(contextPtr,objPtrVar) \ - (objPtrVar) = (contextPtr)->deletionStack; \ +#define PopObjToDelete(contextPtr, objPtrVar) \ + (objPtrVar) = (contextPtr)->deletionStack; \ (contextPtr)->deletionStack = (Tcl_Obj *) (objPtrVar)->bytes /* @@ -168,8 +168,8 @@ static __thread PendingObjData pendingObjData; #else static Tcl_ThreadDataKey pendingObjDataKey; #define ObjInitDeletionContext(contextPtr) \ - PendingObjData *const contextPtr = \ - (PendingObjData *)Tcl_GetThreadData(&pendingObjDataKey, sizeof(PendingObjData)) + PendingObjData *const contextPtr = (PendingObjData *) \ + Tcl_GetThreadData(&pendingObjDataKey, sizeof(PendingObjData)) #endif /* @@ -177,15 +177,15 @@ static Tcl_ThreadDataKey pendingObjDataKey; */ #define PACK_BIGNUM(bignum, objPtr) \ - if ((bignum).used > 0x7FFF) { \ - mp_int *temp = (mp_int *)Tcl_Alloc(sizeof(mp_int)); \ - *temp = bignum; \ - (objPtr)->internalRep.twoPtrValue.ptr1 = temp; \ - (objPtr)->internalRep.twoPtrValue.ptr2 = INT2PTR(-1); \ + if ((bignum).used > 0x7FFF) { \ + mp_int *temp = (mp_int *)Tcl_Alloc(sizeof(mp_int)); \ + *temp = bignum; \ + (objPtr)->internalRep.twoPtrValue.ptr1 = temp; \ + (objPtr)->internalRep.twoPtrValue.ptr2 = INT2PTR(-1); \ } else if (((bignum).alloc <= 0x7FFF) || (mp_shrink(&(bignum))) == MP_OKAY) { \ - (objPtr)->internalRep.twoPtrValue.ptr1 = (bignum).dp; \ + (objPtr)->internalRep.twoPtrValue.ptr1 = (bignum).dp; \ (objPtr)->internalRep.twoPtrValue.ptr2 = INT2PTR(((bignum).sign << 30) \ - | ((bignum).alloc << 15) | ((bignum).used)); \ + | ((bignum).alloc << 15) | ((bignum).used)); \ } /* @@ -548,7 +548,8 @@ TclContinuationsEnter( ThreadSpecificData *tsdPtr = TclGetContLineTable(); Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(tsdPtr->lineCLPtr, objPtr, &newEntry); - ContLineLoc *clLocPtr = (ContLineLoc *)Tcl_Alloc(offsetof(ContLineLoc, loc) + (num + 1U) *sizeof(Tcl_Size)); + ContLineLoc *clLocPtr = (ContLineLoc *) + Tcl_Alloc(offsetof(ContLineLoc, loc) + (num + 1U) *sizeof(Tcl_Size)); if (!newEntry) { /* @@ -810,11 +811,9 @@ Tcl_RegisterObjType( * be statically allocated (must live * forever). */ { - int isNew; - Tcl_MutexLock(&tableMutex); Tcl_SetHashValue( - Tcl_CreateHashEntry(&typeTable, typePtr->name, &isNew), typePtr); + Tcl_CreateHashEntry(&typeTable, typePtr->name, NULL), typePtr); Tcl_MutexUnlock(&tableMutex); } @@ -1034,9 +1033,9 @@ TclDbDumpActiveObjects( void TclDbInitNewObj( Tcl_Obj *objPtr, - const char *file, /* The name of the source file calling this + 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 + int line) /* Line number in the source file; used for * debugging. */ { objPtr->refCount = 0; @@ -1162,9 +1161,9 @@ Tcl_NewObj(void) Tcl_Obj * Tcl_DbNewObj( - const char *file, /* The name of the source file calling this + 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 + int line) /* Line number in the source file; used for * debugging. */ { Tcl_Obj *objPtr; @@ -1583,61 +1582,6 @@ TclSetDuplicateObj( /* *---------------------------------------------------------------------- * - * Tcl_GetString -- - * - * Returns the string representation byte array pointer for an object. - * - * Results: - * Returns a pointer to the string representation of objPtr. The byte - * array referenced by the returned pointer must not be modified by the - * caller. Furthermore, the caller must copy the bytes if they need to - * retain them since the object's string rep can change as a result of - * other operations. - * - * Side effects: - * May call the object's updateStringProc to update the string - * representation from the internal representation. - * - *---------------------------------------------------------------------- - */ - -#undef Tcl_GetString -char * -Tcl_GetString( - Tcl_Obj *objPtr) /* Object whose string rep byte pointer should - * be returned. */ -{ - if (objPtr->bytes == NULL) { - /* - * Note we do not check for objPtr->typePtr == NULL. An invariant - * of a properly maintained Tcl_Obj is that at least one of - * objPtr->bytes and objPtr->typePtr must not be NULL. If broken - * extensions fail to maintain that invariant, we can crash here. - */ - - if (objPtr->typePtr->updateStringProc == NULL) { - /* - * Those Tcl_ObjTypes which choose not to define an - * updateStringProc must be written in such a way that - * (objPtr->bytes) never becomes NULL. - */ - Tcl_Panic("UpdateStringProc should not be invoked for type %s", - objPtr->typePtr->name); - } - objPtr->typePtr->updateStringProc(objPtr); - if (objPtr->bytes == NULL || objPtr->length == TCL_INDEX_NONE - || objPtr->bytes[objPtr->length] != '\0') { - Tcl_Panic("UpdateStringProc for type '%s' " - "failed to create a valid string rep", - objPtr->typePtr->name); - } - } - return objPtr->bytes; -} - -/* - *---------------------------------------------------------------------- - * * Tcl_GetStringFromObj/TclGetStringFromObj -- * * Returns the string representation's byte array pointer and length for @@ -1658,13 +1602,13 @@ Tcl_GetString( *---------------------------------------------------------------------- */ -#if !defined(TCL_NO_DEPRECATED) +#ifndef TCL_NO_DEPRECATED #undef TclGetStringFromObj char * TclGetStringFromObj( - Tcl_Obj *objPtr, /* Object whose string rep byte pointer should + Tcl_Obj *objPtr, /* Object whose string rep byte pointer should * be returned. */ - void *lengthPtr) /* If non-NULL, the location where the string + void *lengthPtr) /* If non-NULL, the location where the string * rep's byte array length should * be stored. * If NULL, no length is stored. */ { @@ -1702,12 +1646,12 @@ TclGetStringFromObj( } return objPtr->bytes; } -#endif /* !defined(TCL_NO_DEPRECATED) */ +#endif /* !TCL_NO_DEPRECATED */ #undef Tcl_GetStringFromObj char * Tcl_GetStringFromObj( - Tcl_Obj *objPtr, /* Object whose string rep byte pointer should + Tcl_Obj *objPtr, /* Object whose string rep byte pointer should * be returned. */ Tcl_Size *lengthPtr) /* If non-NULL, the location where the string * rep's byte array length should * be stored. @@ -1790,7 +1734,7 @@ Tcl_GetStringFromObj( char * Tcl_InitStringRep( - Tcl_Obj *objPtr, /* Object whose string rep is to be set */ + Tcl_Obj *objPtr, /* Object whose string rep is to be set */ const char *bytes, size_t numBytes) { @@ -1861,7 +1805,7 @@ Tcl_InitStringRep( void Tcl_InvalidateStringRep( - Tcl_Obj *objPtr) /* Object whose string rep byte pointer should + Tcl_Obj *objPtr) /* Object whose string rep byte pointer should * be freed. */ { TclInvalidateStringRep(objPtr); @@ -1973,7 +1917,7 @@ Tcl_FetchInternalRep( void Tcl_FreeInternalRep( - Tcl_Obj *objPtr) /* Object whose internal rep should be freed. */ + Tcl_Obj *objPtr) /* Object whose internal rep should be freed. */ { TclFreeInternalRep(objPtr); } @@ -2000,10 +1944,10 @@ Tcl_FreeInternalRep( #undef Tcl_GetBoolFromObj int Tcl_GetBoolFromObj( - Tcl_Interp *interp, /* Used for error reporting if not NULL. */ - Tcl_Obj *objPtr, /* The object from which to get boolean. */ + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + Tcl_Obj *objPtr, /* The object from which to get boolean. */ int flags, - char *charPtr) /* Place to store resulting boolean. */ + char *charPtr) /* Place to store resulting boolean. */ { int result; Tcl_Size length; @@ -2015,13 +1959,15 @@ Tcl_GetBoolFromObj( if (interp) { TclNewObj(objPtr); TclParseNumber(interp, objPtr, (flags & TCL_NULL_OK) - ? "boolean value or \"\"" : "boolean value", NULL, TCL_INDEX_NONE, NULL, 0); + ? "boolean value or \"\"" : "boolean value", NULL, + TCL_INDEX_NONE, NULL, 0); Tcl_DecrRefCount(objPtr); } return TCL_ERROR; } do { - if (TclHasInternalRep(objPtr, &tclIntType) || TclHasInternalRep(objPtr, &tclBooleanType)) { + if (TclHasInternalRep(objPtr, &tclIntType) + || TclHasInternalRep(objPtr, &tclBooleanType)) { result = (objPtr->internalRep.wideValue != 0); goto boolEnd; } @@ -2052,13 +1998,13 @@ Tcl_GetBoolFromObj( *(int *)charPtr = result; return TCL_OK; } else if (flags == (int)sizeof(short)) { - *(short *)charPtr = result; + *(short *)charPtr = (short)result; return TCL_OK; } else { Tcl_Panic("Wrong bool var for %s", "Tcl_GetBoolFromObj"); } } - *charPtr = result; + *charPtr = (char)result; } return TCL_OK; } @@ -2068,7 +2014,8 @@ Tcl_GetBoolFromObj( if (length > 0) { listRep: if (interp) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf("expected boolean value%s but got a list", + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "expected boolean value%s but got a list", (flags & TCL_NULL_OK) ? " or \"\"" : "")); } return TCL_ERROR; @@ -2087,11 +2034,12 @@ Tcl_GetBoolFromObj( #undef Tcl_GetBooleanFromObj int Tcl_GetBooleanFromObj( - Tcl_Interp *interp, /* Used for error reporting if not NULL. */ - Tcl_Obj *objPtr, /* The object from which to get boolean. */ - int *intPtr) /* Place to store resulting boolean. */ + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + Tcl_Obj *objPtr, /* The object from which to get boolean. */ + int *intPtr) /* Place to store resulting boolean. */ { - return Tcl_GetBoolFromObj(interp, objPtr, (TCL_NULL_OK-2)&(int)sizeof(int), (char *)(void *)intPtr); + return Tcl_GetBoolFromObj(interp, objPtr, (TCL_NULL_OK-2)&(int)sizeof(int), + (char *)(void *)intPtr); } /* @@ -2117,7 +2065,7 @@ Tcl_GetBooleanFromObj( int TclSetBooleanFromAny( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ - Tcl_Obj *objPtr) /* The object to convert. */ + Tcl_Obj *objPtr) /* The object to convert. */ { /* * For some "pure" numeric Tcl_ObjTypes (no string rep), we can determine @@ -2163,7 +2111,7 @@ TclSetBooleanFromAny( static int ParseBoolean( - Tcl_Obj *objPtr) /* The object to parse/convert. */ + Tcl_Obj *objPtr) /* The object to parse/convert. */ { int newBool; char lowerCase[6]; @@ -2305,7 +2253,7 @@ ParseBoolean( Tcl_Obj * Tcl_NewDoubleObj( - double dblValue) /* Double used to initialize the object. */ + double dblValue) /* Double used to initialize the object. */ { return Tcl_DbNewDoubleObj(dblValue, "unknown", 0); } @@ -2314,7 +2262,7 @@ Tcl_NewDoubleObj( Tcl_Obj * Tcl_NewDoubleObj( - double dblValue) /* Double used to initialize the object. */ + double dblValue) /* Double used to initialize the object. */ { Tcl_Obj *objPtr; @@ -2353,7 +2301,7 @@ Tcl_NewDoubleObj( Tcl_Obj * Tcl_DbNewDoubleObj( - double dblValue, /* Double used to initialize the object. */ + double dblValue, /* Double used to initialize the 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 @@ -2434,9 +2382,9 @@ Tcl_SetDoubleObj( int Tcl_GetDoubleFromObj( - Tcl_Interp *interp, /* Used for error reporting if not NULL. */ - Tcl_Obj *objPtr, /* The object from which to get a double. */ - double *dblPtr) /* Place to store resulting double. */ + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + Tcl_Obj *objPtr, /* The object from which to get a double. */ + double *dblPtr) /* Place to store resulting double. */ { Tcl_Size length; do { @@ -2470,8 +2418,9 @@ Tcl_GetDoubleFromObj( if (length > 0) { listRep: if (interp) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("expected floating-point number but got a list", TCL_INDEX_NONE)); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "expected floating-point number but got a list", + TCL_INDEX_NONE)); } return TCL_ERROR; } @@ -2576,9 +2525,9 @@ UpdateStringOfDouble( int Tcl_GetIntFromObj( - Tcl_Interp *interp, /* Used for error reporting if not NULL. */ - Tcl_Obj *objPtr, /* The object from which to get a int. */ - int *intPtr) /* Place to store resulting int. */ + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + Tcl_Obj *objPtr, /* The object from which to get a int. */ + int *intPtr) /* Place to store resulting int. */ { #if (LONG_MAX == INT_MAX) return TclGetLongFromObj(interp, objPtr, (long *) intPtr); @@ -2648,7 +2597,7 @@ SetIntFromAny( static void UpdateStringOfInt( - Tcl_Obj *objPtr) /* Int object whose string rep to update. */ + Tcl_Obj *objPtr) /* Int object whose string rep to update. */ { char *dst = Tcl_InitStringRep( objPtr, NULL, TCL_INTEGER_SPACE); @@ -2680,9 +2629,9 @@ UpdateStringOfInt( int Tcl_GetLongFromObj( - Tcl_Interp *interp, /* Used for error reporting if not NULL. */ - Tcl_Obj *objPtr, /* The object from which to get a long. */ - long *longPtr) /* Place to store resulting long. */ + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + Tcl_Obj *objPtr, /* The object from which to get a long. */ + long *longPtr) /* Place to store resulting long. */ { Tcl_Size length; do { @@ -2814,8 +2763,7 @@ Tcl_GetLongFromObj( Tcl_Obj * Tcl_NewWideIntObj( - Tcl_WideInt wideValue) - /* Wide integer used to initialize the new + Tcl_WideInt wideValue) /* Wide integer used to initialize the new * object. */ { return Tcl_DbNewWideIntObj(wideValue, "unknown", 0); @@ -2825,8 +2773,7 @@ Tcl_NewWideIntObj( Tcl_Obj * Tcl_NewWideIntObj( - Tcl_WideInt wideValue) - /* Wide integer used to initialize the new + Tcl_WideInt wideValue) /* Wide integer used to initialize the new * object. */ { Tcl_Obj *objPtr; @@ -2854,8 +2801,7 @@ Tcl_NewWideIntObj( Tcl_Obj * Tcl_NewWideUIntObj( - Tcl_WideUInt uwideValue) - /* Wide integer used to initialize the new + Tcl_WideUInt uwideValue) /* Wide integer used to initialize the new * object. */ { Tcl_Obj *objPtr; @@ -2900,8 +2846,7 @@ Tcl_NewWideUIntObj( Tcl_Obj * Tcl_DbNewWideIntObj( - Tcl_WideInt wideValue, - /* Wide integer used to initialize the new + Tcl_WideInt wideValue, /* Wide integer used to initialize the new * object. */ const char *file, /* The name of the source file calling this * function; used for debugging. */ @@ -2919,8 +2864,7 @@ Tcl_DbNewWideIntObj( Tcl_Obj * Tcl_DbNewWideIntObj( - Tcl_WideInt wideValue, - /* Long integer used to initialize the new + Tcl_WideInt wideValue, /* Long integer used to initialize the new * object. */ TCL_UNUSED(const char *) /*file*/, TCL_UNUSED(int) /*line*/) @@ -2949,9 +2893,8 @@ Tcl_DbNewWideIntObj( void Tcl_SetWideIntObj( - Tcl_Obj *objPtr, /* Object w. internal rep to init. */ - Tcl_WideInt wideValue) - /* Wide integer used to initialize the + Tcl_Obj *objPtr, /* Object w. internal rep to init. */ + Tcl_WideInt wideValue) /* Wide integer used to initialize the * object's value. */ { if (Tcl_IsShared(objPtr)) { @@ -2981,9 +2924,8 @@ Tcl_SetWideIntObj( void Tcl_SetWideUIntObj( - Tcl_Obj *objPtr, /* Object w. internal rep to init. */ - Tcl_WideUInt uwideValue) - /* Wide integer used to initialize the + Tcl_Obj *objPtr, /* Object w. internal rep to init. */ + Tcl_WideUInt uwideValue) /* Wide integer used to initialize the * object's value. */ { if (Tcl_IsShared(objPtr)) { @@ -3024,10 +2966,9 @@ Tcl_SetWideUIntObj( int Tcl_GetWideIntFromObj( - Tcl_Interp *interp, /* Used for error reporting if not NULL. */ - Tcl_Obj *objPtr, /* Object from which to get a wide int. */ - Tcl_WideInt *wideIntPtr) - /* Place to store resulting long. */ + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + Tcl_Obj *objPtr, /* Object from which to get a wide int. */ + Tcl_WideInt *wideIntPtr) /* Place to store resulting long. */ { Tcl_Size length; do { @@ -3125,10 +3066,9 @@ Tcl_GetWideIntFromObj( int Tcl_GetWideUIntFromObj( - Tcl_Interp *interp, /* Used for error reporting if not NULL. */ - Tcl_Obj *objPtr, /* Object from which to get a wide int. */ - Tcl_WideUInt *wideUIntPtr) - /* Place to store resulting long. */ + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + Tcl_Obj *objPtr, /* Object from which to get a wide int. */ + Tcl_WideUInt *wideUIntPtr) /* Place to store resulting long. */ { do { if (TclHasInternalRep(objPtr, &tclIntType)) { @@ -3210,9 +3150,9 @@ Tcl_GetWideUIntFromObj( int TclGetWideBitsFromObj( - Tcl_Interp *interp, /* Used for error reporting if not NULL. */ - Tcl_Obj *objPtr, /* Object from which to get a wide int. */ - Tcl_WideInt *wideIntPtr) /* Place to store resulting wide integer. */ + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + Tcl_Obj *objPtr, /* Object from which to get a wide int. */ + Tcl_WideInt *wideIntPtr) /* Place to store resulting wide integer. */ { do { if (TclHasInternalRep(objPtr, &tclIntType)) { @@ -3274,9 +3214,9 @@ TclGetWideBitsFromObj( */ int Tcl_GetSizeIntFromObj( - Tcl_Interp *interp, /* Used for error reporting if not NULL. */ - Tcl_Obj *objPtr, /* The object from which to get a int. */ - Tcl_Size *sizePtr) /* Place to store resulting int. */ + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + Tcl_Obj *objPtr, /* The object from which to get a int. */ + Tcl_Size *sizePtr) /* Place to store resulting int. */ { if (sizeof(Tcl_Size) == sizeof(int)) { return TclGetIntFromObj(interp, objPtr, (int *)sizePtr); @@ -3586,7 +3526,7 @@ int Tcl_GetBignumFromObj( Tcl_Interp *interp, /* Tcl interpreter for error reporting */ Tcl_Obj *objPtr, /* Object to read */ - void *bignumValue) /* Returned bignum value. */ + void *bignumValue) /* Returned bignum value. */ { return GetBignumFromObj(interp, objPtr, 1, (mp_int *)bignumValue); } @@ -3621,7 +3561,7 @@ int Tcl_TakeBignumFromObj( Tcl_Interp *interp, /* Tcl interpreter for error reporting */ Tcl_Obj *objPtr, /* Object to read */ - void *bignumValue) /* Returned bignum value. */ + void *bignumValue) /* Returned bignum value. */ { return GetBignumFromObj(interp, objPtr, 0, (mp_int *)bignumValue); } @@ -3646,7 +3586,7 @@ Tcl_TakeBignumFromObj( void Tcl_SetBignumObj( Tcl_Obj *objPtr, /* Object to set */ - void *big) /* Value to store */ + void *big) /* Value to store */ { Tcl_WideUInt value = 0; size_t numBytes; @@ -3938,7 +3878,7 @@ Tcl_IsShared( #ifdef TCL_MEM_DEBUG void Tcl_DbIncrRefCount( - Tcl_Obj *objPtr, /* The object we are registering a reference + Tcl_Obj *objPtr, /* The object we are registering a reference * to. */ const char *file, /* The name of the source file calling this * function; used for debugging. */ @@ -4011,7 +3951,7 @@ Tcl_DbIncrRefCount( #ifdef TCL_MEM_DEBUG void Tcl_DbDecrRefCount( - Tcl_Obj *objPtr, /* The object we are releasing a reference + Tcl_Obj *objPtr, /* The object we are releasing a reference * to. */ const char *file, /* The name of the source file calling this * function; used for debugging. */ @@ -4088,16 +4028,17 @@ Tcl_DbDecrRefCount( int Tcl_DbIsShared( - Tcl_Obj *objPtr, /* The object to test for being shared. */ + Tcl_Obj *objPtr, /* The object to test for being shared. */ #ifdef TCL_MEM_DEBUG 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 + int line /* Line number in the source file; used for * debugging. */ #else TCL_UNUSED(const char *) /*file*/, - TCL_UNUSED(int) /*line*/) + TCL_UNUSED(int) /*line*/ #endif + ) { #ifdef TCL_MEM_DEBUG if (objPtr->refCount == FREEDREFCOUNTFILLER) { @@ -4165,8 +4106,7 @@ Tcl_DbIsShared( void Tcl_InitObjHashTable( - Tcl_HashTable *tablePtr) - /* Pointer to table record, which is supplied + Tcl_HashTable *tablePtr) /* Pointer to table record, which is supplied * by the caller. */ { Tcl_InitCustomHashTable(tablePtr, TCL_CUSTOM_PTR_KEYS, @@ -4195,11 +4135,13 @@ AllocObjEntry( void *keyPtr) /* Key to store in the hash table entry. */ { Tcl_Obj *objPtr = (Tcl_Obj *)keyPtr; - Tcl_HashEntry *hPtr = (Tcl_HashEntry *)Tcl_Alloc(sizeof(Tcl_HashEntry)); + Tcl_HashEntry *hPtr = (Tcl_HashEntry *)Tcl_AttemptAlloc(sizeof(Tcl_HashEntry)); - hPtr->key.objPtr = objPtr; - Tcl_IncrRefCount(objPtr); - hPtr->clientData = NULL; + if (hPtr) { + hPtr->key.objPtr = objPtr; + Tcl_IncrRefCount(objPtr); + hPtr->clientData = NULL; + } return hPtr; } @@ -4235,10 +4177,10 @@ TclCompareObjKeys( * If the object pointers are the same then they match. * OPT: this comparison was moved to the caller - if (objPtr1 == objPtr2) { - return 1; - } - */ + if (objPtr1 == objPtr2) { + return 1; + } + */ /* * Don't use Tcl_GetStringFromObj as it would prevent l1 and l2 being diff --git a/generic/tclOptimize.c b/generic/tclOptimize.c index cf5177a..0ff20f9 100644 --- a/generic/tclOptimize.c +++ b/generic/tclOptimize.c @@ -10,6 +10,7 @@ */ #include "tclInt.h" +#define ALLOW_DEPRECATED_OPCODES #include "tclCompile.h" #include <assert.h> @@ -79,38 +80,48 @@ LocateTargetAddresses( currentInstPtr < envPtr->codeNext ; currentInstPtr += AddrLength(currentInstPtr)) { switch (*currentInstPtr) { +#ifndef REMOVE_DEPRECATED_OPCODES case INST_JUMP1: case INST_JUMP_TRUE1: case INST_JUMP_FALSE1: targetInstPtr = currentInstPtr+TclGetInt1AtPtr(currentInstPtr+1); goto storeTarget; - case INST_JUMP4: - case INST_JUMP_TRUE4: - case INST_JUMP_FALSE4: +#endif + case INST_JUMP: + case INST_JUMP_TRUE: + case INST_JUMP_FALSE: case INST_START_CMD: targetInstPtr = currentInstPtr+TclGetInt4AtPtr(currentInstPtr+1); goto storeTarget; - case INST_BEGIN_CATCH4: + case INST_BEGIN_CATCH: targetInstPtr = envPtr->codeStart + envPtr->exceptArrayPtr[ TclGetUInt4AtPtr(currentInstPtr+1)].codeOffset; storeTarget: DefineTargetAddress(tablePtr, targetInstPtr); break; + case INST_JUMP_TABLE_NUM: + hPtr = Tcl_FirstHashEntry( + &JUMPTABLENUMINFO(envPtr, currentInstPtr+1)->hashTable, + &hSearch); + goto storeJumpTableTargets; case INST_JUMP_TABLE: hPtr = Tcl_FirstHashEntry( &JUMPTABLEINFO(envPtr, currentInstPtr+1)->hashTable, &hSearch); + storeJumpTableTargets: for (; hPtr ; hPtr = Tcl_NextHashEntry(&hSearch)) { targetInstPtr = currentInstPtr + PTR2INT(Tcl_GetHashValue(hPtr)); DefineTargetAddress(tablePtr, targetInstPtr); } break; +#ifndef REMOVE_DEPRECATED_OPCODES case INST_RETURN_CODE_BRANCH: for (i=TCL_ERROR ; i<TCL_CONTINUE+1 ; i++) { DefineTargetAddress(tablePtr, currentInstPtr + 2*i - 1); } break; +#endif } } @@ -240,7 +251,7 @@ ConvertZeroEffectToNOP( } } break; - case INST_PUSH4: + case INST_PUSH: if (nextInst == INST_POP) { blank = size + 1; } else if (nextInst == INST_STR_CONCAT1 @@ -258,6 +269,7 @@ ConvertZeroEffectToNOP( case INST_LNOT: switch (nextInst) { +#ifndef REMOVE_DEPRECATED_OPCODES case INST_JUMP_TRUE1: blank = size; currentInstPtr[size] = INST_JUMP_FALSE1; @@ -266,25 +278,30 @@ ConvertZeroEffectToNOP( blank = size; currentInstPtr[size] = INST_JUMP_TRUE1; break; - case INST_JUMP_TRUE4: +#endif + case INST_JUMP_TRUE: blank = size; - currentInstPtr[size] = INST_JUMP_FALSE4; + currentInstPtr[size] = INST_JUMP_FALSE; break; - case INST_JUMP_FALSE4: + case INST_JUMP_FALSE: blank = size; - currentInstPtr[size] = INST_JUMP_TRUE4; + currentInstPtr[size] = INST_JUMP_TRUE; break; } break; case INST_TRY_CVT_TO_NUMERIC: switch (nextInst) { +#ifndef REMOVE_DEPRECATED_OPCODES case INST_JUMP_TRUE1: - case INST_JUMP_TRUE4: case INST_JUMP_FALSE1: - case INST_JUMP_FALSE4: +#endif + case INST_JUMP_TRUE: + case INST_JUMP_FALSE: case INST_INCR_SCALAR1: + case INST_INCR_SCALAR: case INST_INCR_ARRAY1: + case INST_INCR_ARRAY: case INST_INCR_ARRAY_STK: case INST_INCR_SCALAR_STK: case INST_INCR_STK: @@ -351,6 +368,7 @@ AdvanceJumps( int offset, delta, isNew; switch (*currentInstPtr) { +#ifndef REMOVE_DEPRECATED_OPCODES case INST_JUMP1: case INST_JUMP_TRUE1: case INST_JUMP_FALSE1: @@ -373,7 +391,7 @@ AdvanceJumps( case INST_JUMP1: delta = TclGetInt1AtPtr(currentInstPtr + offset + 1); continue; - case INST_JUMP4: + case INST_JUMP: delta = TclGetInt4AtPtr(currentInstPtr + offset + 1); continue; } @@ -382,12 +400,13 @@ AdvanceJumps( Tcl_DeleteHashTable(&jumps); TclStoreInt1AtPtr(offset, currentInstPtr + 1); continue; +#endif - case INST_JUMP4: - case INST_JUMP_TRUE4: - case INST_JUMP_FALSE4: + case INST_JUMP: + case INST_JUMP_TRUE: + case INST_JUMP_FALSE: Tcl_InitHashTable(&jumps, TCL_ONE_WORD_KEYS); - Tcl_CreateHashEntry(&jumps, INT2PTR(0), &isNew); + Tcl_CreateHashEntry(&jumps, INT2PTR(0), NULL); for (offset = TclGetInt4AtPtr(currentInstPtr + 1); offset!=0 ;) { Tcl_CreateHashEntry(&jumps, INT2PTR(offset), &isNew); if (!isNew) { @@ -398,10 +417,12 @@ AdvanceJumps( case INST_NOP: offset += InstLength(INST_NOP); continue; +#ifndef REMOVE_DEPRECATED_OPCODES case INST_JUMP1: offset += TclGetInt1AtPtr(currentInstPtr + offset + 1); continue; - case INST_JUMP4: +#endif + case INST_JUMP: offset += TclGetInt4AtPtr(currentInstPtr + offset + 1); continue; } @@ -417,6 +438,71 @@ AdvanceJumps( /* * ---------------------------------------------------------------------- * + * BetterEqualityTesting -- + * + * Convert PUSH("");OP(STR_EQ); into OP(IS_EMPTY); and some NOPs. + * + * ---------------------------------------------------------------------- + */ + +static void +BetterEqualityTesting( + CompileEnv *envPtr) +{ + unsigned char *currentInstPtr, *emptyPushInstPtr = NULL; + Tcl_HashTable targets; + + LocateTargetAddresses(envPtr, &targets); + for (currentInstPtr = envPtr->codeStart ; + currentInstPtr < envPtr->codeNext-1 ; + currentInstPtr += AddrLength(currentInstPtr)) { + if (emptyPushInstPtr && IsTargetAddress(&targets, currentInstPtr)) { + emptyPushInstPtr = NULL; + } + switch (*currentInstPtr) { + case INST_PUSH: { + Tcl_Size idx = TclGetUInt4AtPtr(currentInstPtr + 1); + Tcl_Obj *literal = TclFetchLiteral(envPtr, idx); + if (literal->bytes && literal->length == 0) { + emptyPushInstPtr = currentInstPtr; + } else { + emptyPushInstPtr = NULL; + } + break; + } + case INST_EQ: + case INST_STR_EQ: + if (emptyPushInstPtr != NULL) { + while (emptyPushInstPtr < currentInstPtr) { + *emptyPushInstPtr++ = INST_NOP; + } + *currentInstPtr = INST_IS_EMPTY; + } + emptyPushInstPtr = NULL; + break; + case INST_NEQ: + case INST_STR_NEQ: + if (emptyPushInstPtr != NULL) { + while (emptyPushInstPtr < currentInstPtr) { + *emptyPushInstPtr++ = INST_NOP; + } + currentInstPtr[-1] = INST_IS_EMPTY; + currentInstPtr[0] = INST_LNOT; + } + emptyPushInstPtr = NULL; + break; + case INST_NOP: + break; + default: + emptyPushInstPtr = NULL; + } + } + Tcl_DeleteHashTable(&targets); +} + +/* + * ---------------------------------------------------------------------- + * * TclOptimizeBytecode -- * * A very simple peephole optimizer for bytecode. @@ -428,9 +514,11 @@ void TclOptimizeBytecode( void *envPtr) { - ConvertZeroEffectToNOP((CompileEnv *)envPtr); - AdvanceJumps((CompileEnv *)envPtr); - TrimUnreachable((CompileEnv *)envPtr); + CompileEnv *realEnvPtr = (CompileEnv *) envPtr; + ConvertZeroEffectToNOP(realEnvPtr); + BetterEqualityTesting(realEnvPtr); + AdvanceJumps(realEnvPtr); + TrimUnreachable(realEnvPtr); } /* diff --git a/generic/tclParse.c b/generic/tclParse.c index 88368cc..3f9b0d8 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -129,7 +129,7 @@ static Tcl_Size ParseWhiteSpace(const char *src, Tcl_Size numBytes, int *incompletePtr, char *typePtr); static Tcl_Size ParseAllWhiteSpace(const char *src, Tcl_Size numBytes, int *incompletePtr); -static int ParseHex(const char *src, Tcl_Size numBytes, +static Tcl_Size ParseHex(const char *src, Tcl_Size numBytes, int *resultPtr); /* @@ -205,8 +205,7 @@ Tcl_ParseCommand( * close bracket should be considered a * command terminator. If zero, then close * bracket has no special meaning. */ - Tcl_Parse *parsePtr) - /* Structure to fill in with information about + Tcl_Parse *parsePtr) /* Structure to fill in with information about * the parsed command; any previous * information in the structure is ignored. */ { @@ -725,7 +724,7 @@ TclParseAllWhiteSpace( *---------------------------------------------------------------------- */ -int +Tcl_Size ParseHex( const char *src, /* First character to parse. */ Tcl_Size numBytes, /* Max number of byes to scan */ @@ -780,7 +779,7 @@ ParseHex( *---------------------------------------------------------------------- */ -int +Tcl_Size TclParseBackslash( const char *src, /* Points to the backslash character of a * backslash sequence. */ @@ -1330,7 +1329,7 @@ Tcl_ParseVarName( { Tcl_Token *tokenPtr; const char *src; - int varIndex; + Tcl_Size varIndex; unsigned array; if (numBytes < 0 && start) { @@ -1403,7 +1402,8 @@ Tcl_ParseVarName( /* if 2 or more left, consume 2, else consume * just the \ and let it run into the end */ if (numBytes > 1) { - src++; numBytes--; + src++; + numBytes--; } } numBytes--; @@ -1624,8 +1624,7 @@ Tcl_ParseBraces( Tcl_Size numBytes, /* Total number of bytes in string. If -1, * the string consists of all bytes up to the * first null character. */ - Tcl_Parse *parsePtr, - /* Structure to fill in with information about + Tcl_Parse *parsePtr, /* Structure to fill in with information about * the string. */ int append, /* Non-zero means append tokens to existing * information in parsePtr; zero means ignore @@ -1825,8 +1824,7 @@ Tcl_ParseQuotedString( Tcl_Size numBytes, /* Total number of bytes in string. If -1, * the string consists of all bytes up to the * first null character. */ - Tcl_Parse *parsePtr, - /* Structure to fill in with information about + Tcl_Parse *parsePtr, /* Structure to fill in with information about * the string. */ int append, /* Non-zero means append tokens to existing * information in parsePtr; zero means ignore @@ -2104,10 +2102,10 @@ TclSubstTokens( * evaluate and concatenate. */ Tcl_Size count, /* Number of tokens to consider at tokenPtr. * Must be at least 1. */ - int *tokensLeftPtr, /* If not NULL, points to memory where an + Tcl_Size *tokensLeftPtr, /* If not NULL, points to memory where an * integer representing the number of tokens * left to be substituted will be written */ - Tcl_Size line, /* The line the script starts on. */ + int line, /* The line the script starts on. */ Tcl_Size *clNextOuter, /* Information about an outer context for */ const char *outerScript) /* continuation line data. This is set by * EvalEx() to properly handle [...]-nested @@ -2174,7 +2172,7 @@ TclSubstTokens( for (; count>0 && code==TCL_OK ; count--, tokenPtr++) { Tcl_Obj *appendObj = NULL; const char *append = NULL; - int appendByteLength = 0; + Tcl_Size appendByteLength = 0; char utfCharBytes[4] = ""; switch (tokenPtr->type) { diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index 02aa402..be64423 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -55,17 +55,17 @@ static const Tcl_ObjType fsPathType = { */ typedef struct { - Tcl_Obj *translatedPathPtr; /* If the path has been normalized (flags == - * 0), this is NULL. Otherwise it is a path - * in which any ~user sequences have been - * translated away. */ - Tcl_Obj *normPathPtr; /* If the path has been normalized (flags == - * 0), this is an absolute path without ., .. - * or ~user components. Otherwise it is a - * path, possibly absolute, to normalize - * relative to cwdPtr. */ - Tcl_Obj *cwdPtr; /* If NULL, either translatedPtr exists or - * normPathPtr exists and is absolute. */ + Tcl_Obj *translatedPathPtr; /* If the path has been normalized (flags == + * 0), this is NULL. Otherwise it is a path + * in which any ~user sequences have been + * translated away. */ + Tcl_Obj *normPathPtr; /* If the path has been normalized (flags == + * 0), this is an absolute path without ., .. + * or ~user components. Otherwise it is a + * path, possibly absolute, to normalize + * relative to cwdPtr. */ + Tcl_Obj *cwdPtr; /* If NULL, either translatedPtr exists or + * normPathPtr exists and is absolute. */ int flags; /* Flags to describe interpretation - see * below. */ void *nativePathPtr; /* Native representation of this path, which @@ -89,14 +89,15 @@ typedef struct { * fields. */ -#define PATHOBJ(pathPtr) ((FsPath *) (TclFetchInternalRep((pathPtr), &fsPathType)->twoPtrValue.ptr1)) +#define PATHOBJ(pathPtr) \ + ((FsPath *) (TclFetchInternalRep((pathPtr), &fsPathType)->twoPtrValue.ptr1)) #define SETPATHOBJ(pathPtr,fsPathPtr) \ - do { \ - Tcl_ObjInternalRep ir; \ - ir.twoPtrValue.ptr1 = (void *) (fsPathPtr); \ - ir.twoPtrValue.ptr2 = NULL; \ - Tcl_StoreInternalRep((pathPtr), &fsPathType, &ir); \ - } while (0) + do { \ + Tcl_ObjInternalRep ir; \ + ir.twoPtrValue.ptr1 = (void *) (fsPathPtr); \ + ir.twoPtrValue.ptr2 = NULL; \ + Tcl_StoreInternalRep((pathPtr), &fsPathType, &ir); \ + } while (0) #define PATHFLAGS(pathPtr) (PATHOBJ(pathPtr)->flags) /* @@ -2563,11 +2564,11 @@ TclGetHomeDirObj( * *---------------------------------------------------------------------- */ -int Tcl_FSTildeExpand( - Tcl_Interp *interp, /* May be NULL. Only used for error messages */ - const char *path, /* Path to resolve tilde */ - Tcl_DString *dsPtr) /* Output DString for resolved path. */ - +int +Tcl_FSTildeExpand( + Tcl_Interp *interp, /* May be NULL. Only used for error messages */ + const char *path, /* Path to resolve tilde */ + Tcl_DString *dsPtr) /* Output DString for resolved path. */ { Tcl_Size split; int result; @@ -2603,7 +2604,7 @@ int Tcl_FSTildeExpand( /* path[split] is / for ~user/... or \0 for ~user */ result = MakeTildeRelativePath(interp, user, - path[split] ? &path[split + 1] : NULL, dsPtr); + path[split] ? &path[split + 1] : NULL, dsPtr); Tcl_DStringFree(&dsUser); } if (result != TCL_OK) { diff --git a/generic/tclPipe.c b/generic/tclPipe.c index 1efe1ba..1b43e11 100644 --- a/generic/tclPipe.c +++ b/generic/tclPipe.c @@ -194,7 +194,6 @@ Tcl_DetachPids( detList = detPtr; } Tcl_MutexUnlock(&pipeMutex); - } /* @@ -330,7 +329,7 @@ TclCleanupChildren( */ if (interp != NULL) { - int count; + Tcl_Size count; Tcl_Obj *objPtr; Tcl_Seek(errorChan, 0, SEEK_SET); diff --git a/generic/tclPkg.c b/generic/tclPkg.c index de7f6cf..a8cbd3c 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -50,6 +50,9 @@ typedef struct PkgFiles { * package. */ } PkgFiles; +/* Associated data key used to look up the PkgFiles for an interpreter. */ +#define ASSOC_KEY "tclPkgFiles" + /* * For each package that is known in any way to an interpreter, there is one * record of the following type. These records are stored in the @@ -86,12 +89,12 @@ static int CompareVersions(char *v1i, char *v2i, int *isMajorPtr); static int CheckRequirement(Tcl_Interp *interp, const char *string); -static int CheckAllRequirements(Tcl_Interp *interp, int reqc, +static int CheckAllRequirements(Tcl_Interp *interp, Tcl_Size reqc, Tcl_Obj *const reqv[]); static int RequirementSatisfied(char *havei, const char *req); -static int SomeRequirementSatisfied(char *havei, int reqc, +static int SomeRequirementSatisfied(char *havei, Tcl_Size reqc, Tcl_Obj *const reqv[]); -static void AddRequirementsToResult(Tcl_Interp *interp, int reqc, +static void AddRequirementsToResult(Tcl_Interp *interp, Tcl_Size reqc, Tcl_Obj *const reqv[]); static void AddRequirementsToDString(Tcl_DString *dstring, int reqc, Tcl_Obj *const reqv[]); @@ -101,7 +104,8 @@ static int PkgRequireCoreFinal(void *data[], Tcl_Interp *interp, int result); static int PkgRequireCoreCleanup(void *data[], Tcl_Interp *interp, int result); static int PkgRequireCoreStep1(void *data[], Tcl_Interp *interp, int result); static int PkgRequireCoreStep2(void *data[], Tcl_Interp *interp, int result); -static int TclNRPkgRequireProc(void *clientData, Tcl_Interp *interp, int reqc, Tcl_Obj *const reqv[]); +static int TclNRPkgRequireProc(void *clientData, Tcl_Interp *interp, + int reqc, Tcl_Obj *const reqv[]); static int SelectPackage(void *data[], Tcl_Interp *interp, int result); static int SelectPackageFinal(void *data[], Tcl_Interp *interp, int result); static int TclNRPackageObjCmdCleanup(void *data[], Tcl_Interp *interp, int result); @@ -258,13 +262,13 @@ TclInitPkgFiles( * If assocdata "tclPkgFiles" doesn't exist yet, create it. */ - PkgFiles *pkgFiles = (PkgFiles *)Tcl_GetAssocData(interp, "tclPkgFiles", NULL); + PkgFiles *pkgFiles = (PkgFiles *)Tcl_GetAssocData(interp, ASSOC_KEY, NULL); if (!pkgFiles) { pkgFiles = (PkgFiles *)Tcl_Alloc(sizeof(PkgFiles)); pkgFiles->names = NULL; Tcl_InitHashTable(&pkgFiles->table, TCL_STRING_KEYS); - Tcl_SetAssocData(interp, "tclPkgFiles", PkgFilesCleanupProc, pkgFiles); + Tcl_SetAssocData(interp, ASSOC_KEY, PkgFilesCleanupProc, pkgFiles); } return pkgFiles; } @@ -274,8 +278,7 @@ TclPkgFileSeen( Tcl_Interp *interp, const char *fileName) { - PkgFiles *pkgFiles = (PkgFiles *) - Tcl_GetAssocData(interp, "tclPkgFiles", NULL); + PkgFiles *pkgFiles = (PkgFiles *) Tcl_GetAssocData(interp, ASSOC_KEY, NULL); if (pkgFiles && pkgFiles->names) { const char *name = pkgFiles->names->name; @@ -583,7 +586,7 @@ PkgRequireCoreFinal( TCL_UNUSED(int)) { Require *reqPtr = (Require *)data[0]; - int reqc = (int)PTR2INT(data[1]), satisfies; + Tcl_Size reqc = PTR2INT(data[1]), satisfies; Tcl_Obj **const reqv = (Tcl_Obj **)data[2]; char *pkgVersionI; void *clientDataPtr = reqPtr->clientDataPtr; @@ -649,7 +652,7 @@ SelectPackage( /* Internal rep. of versions */ int availStable, satisfies; Require *reqPtr = (Require *)data[0]; - int reqc = (int)PTR2INT(data[1]); + Tcl_Size reqc = PTR2INT(data[1]); Tcl_Obj **const reqv = (Tcl_Obj **)data[2]; const char *name = reqPtr->name; Package *pkgPtr = reqPtr->pkgPtr; @@ -857,7 +860,7 @@ SelectPackageFinal( * Pop the "ifneeded" package name from "tclPkgFiles" assocdata */ - PkgFiles *pkgFiles = (PkgFiles *)Tcl_GetAssocData(interp, "tclPkgFiles", NULL); + PkgFiles *pkgFiles = (PkgFiles *)Tcl_GetAssocData(interp, ASSOC_KEY, NULL); PkgName *pkgName = pkgFiles->names; pkgFiles->names = pkgName->nextPtr; Tcl_Free(pkgName); @@ -1103,7 +1106,7 @@ TclNRPackageObjCmd( return TCL_ERROR; } PkgFiles *pkgFiles = (PkgFiles *) - Tcl_GetAssocData(interp, "tclPkgFiles", NULL); + Tcl_GetAssocData(interp, ASSOC_KEY, NULL); if (pkgFiles) { Tcl_HashEntry *entry = Tcl_FindHashEntry(&pkgFiles->table, TclGetString(objv[2])); @@ -1116,7 +1119,7 @@ TclNRPackageObjCmd( } case PKG_FORGET: { PkgFiles *pkgFiles = (PkgFiles *) - Tcl_GetAssocData(interp, "tclPkgFiles", NULL); + Tcl_GetAssocData(interp, ASSOC_KEY, NULL); for (i = 2; i < objc; i++) { const char *keyString = TclGetString(objv[i]); @@ -1951,10 +1954,10 @@ CompareVersions( static int CheckAllRequirements( Tcl_Interp *interp, - int reqc, /* Requirements to check. */ + Tcl_Size reqc, /* Requirements to check. */ Tcl_Obj *const reqv[]) { - int i; + Tcl_Size i; for (i = 0; i < reqc; i++) { if ((CheckRequirement(interp, TclGetString(reqv[i])) != TCL_OK)) { @@ -2057,7 +2060,7 @@ CheckRequirement( static void AddRequirementsToResult( Tcl_Interp *interp, - int reqc, /* Requirements constraining the desired + Tcl_Size reqc, /* Requirements constraining the desired * version. */ Tcl_Obj *const reqv[]) /* 0 means to use the latest version * available. */ @@ -2137,12 +2140,12 @@ static int SomeRequirementSatisfied( char *availVersionI, /* Candidate version to check against the * requirements. */ - int reqc, /* Requirements constraining the desired + Tcl_Size reqc, /* Requirements constraining the desired * version. */ Tcl_Obj *const reqv[]) /* 0 means to use the latest version * available. */ { - int i; + Tcl_Size i; for (i = 0; i < reqc; i++) { if (RequirementSatisfied(availVersionI, TclGetString(reqv[i]))) { diff --git a/generic/tclPlatDecls.h b/generic/tclPlatDecls.h index fb7f616..6d49ce4 100644 --- a/generic/tclPlatDecls.h +++ b/generic/tclPlatDecls.h @@ -48,94 +48,6 @@ # endif #endif -#if TCL_MAJOR_VERSION < 9 - -#ifdef __cplusplus -extern "C" { -#endif - -/* - * Exported function declarations: - */ - -#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ -/* 0 */ -EXTERN TCHAR * Tcl_WinUtfToTChar(const char *str, int len, - Tcl_DString *dsPtr); -/* 1 */ -EXTERN char * Tcl_WinTCharToUtf(const TCHAR *str, int len, - Tcl_DString *dsPtr); -/* Slot 2 is reserved */ -/* 3 */ -EXTERN void Tcl_WinConvertError(unsigned errCode); -#endif /* WIN */ -#ifdef MAC_OSX_TCL /* MACOSX */ -/* 0 */ -EXTERN int Tcl_MacOSXOpenBundleResources(Tcl_Interp *interp, - const char *bundleName, int hasResourceFile, - Tcl_Size maxPathLen, char *libraryPath); -/* 1 */ -EXTERN int Tcl_MacOSXOpenVersionedBundleResources( - Tcl_Interp *interp, const char *bundleName, - const char *bundleVersion, - int hasResourceFile, Tcl_Size maxPathLen, - char *libraryPath); -/* 2 */ -EXTERN void Tcl_MacOSXNotifierAddRunLoopMode( - const void *runLoopMode); -#endif /* MACOSX */ - -typedef struct TclPlatStubs { - int magic; - void *hooks; - -#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ - TCHAR * (*tcl_WinUtfToTChar) (const char *str, int len, Tcl_DString *dsPtr); /* 0 */ - char * (*tcl_WinTCharToUtf) (const TCHAR *str, int len, Tcl_DString *dsPtr); /* 1 */ - void (*reserved2)(void); - void (*tcl_WinConvertError) (unsigned errCode); /* 3 */ -#endif /* WIN */ -#ifdef MAC_OSX_TCL /* MACOSX */ - int (*tcl_MacOSXOpenBundleResources) (Tcl_Interp *interp, const char *bundleName, int hasResourceFile, Tcl_Size maxPathLen, char *libraryPath); /* 0 */ - int (*tcl_MacOSXOpenVersionedBundleResources) (Tcl_Interp *interp, const char *bundleName, const char *bundleVersion, int hasResourceFile, Tcl_Size maxPathLen, char *libraryPath); /* 1 */ - void (*tcl_MacOSXNotifierAddRunLoopMode) (const void *runLoopMode); /* 2 */ -#endif /* MACOSX */ -} TclPlatStubs; - -extern const TclPlatStubs *tclPlatStubsPtr; - -#ifdef __cplusplus -} -#endif - -#if defined(USE_TCL_STUBS) - -/* - * Inline function declarations: - */ - -#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ -#define Tcl_WinUtfToTChar \ - (tclPlatStubsPtr->tcl_WinUtfToTChar) /* 0 */ -#define Tcl_WinTCharToUtf \ - (tclPlatStubsPtr->tcl_WinTCharToUtf) /* 1 */ -/* Slot 2 is reserved */ -#define Tcl_WinConvertError \ - (tclPlatStubsPtr->tcl_WinConvertError) /* 3 */ -#endif /* WIN */ -#ifdef MAC_OSX_TCL /* MACOSX */ -#define Tcl_MacOSXOpenBundleResources \ - (tclPlatStubsPtr->tcl_MacOSXOpenBundleResources) /* 0 */ -#define Tcl_MacOSXOpenVersionedBundleResources \ - (tclPlatStubsPtr->tcl_MacOSXOpenVersionedBundleResources) /* 1 */ -#define Tcl_MacOSXNotifierAddRunLoopMode \ - (tclPlatStubsPtr->tcl_MacOSXNotifierAddRunLoopMode) /* 2 */ -#endif /* MACOSX */ - -#endif /* defined(USE_TCL_STUBS) */ - -#else /* TCL_MAJOR_VERSION > 8 */ - /* !BEGIN!: Do not edit below this line. */ #ifdef __cplusplus @@ -193,8 +105,6 @@ extern const TclPlatStubs *tclPlatStubsPtr; /* !END!: Do not edit above this line. */ -#endif /* TCL_MAJOR_VERSION */ - #ifdef MAC_OSX_TCL /* MACOSX */ #undef Tcl_MacOSXOpenBundleResources #define Tcl_MacOSXOpenBundleResources(a,b,c,d,e) Tcl_MacOSXOpenVersionedBundleResources(a,b,NULL,c,d,e) @@ -213,16 +123,11 @@ extern const TclPlatStubs *tclPlatStubsPtr; # undef Tcl_MacOSXNotifierAddRunLoopMode #endif -#if defined(USE_TCL_STUBS) && (defined(_WIN32) || defined(__CYGWIN__))\ - && (defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8) -#undef Tcl_WinUtfToTChar -#undef Tcl_WinTCharToUtf #ifdef _WIN32 #define Tcl_WinUtfToTChar(string, len, dsPtr) (Tcl_DStringInit(dsPtr), \ (TCHAR *)Tcl_UtfToChar16DString((string), (len), (dsPtr))) #define Tcl_WinTCharToUtf(string, len, dsPtr) (Tcl_DStringInit(dsPtr), \ Tcl_Char16ToUtfDString((const unsigned short *)(string), ((((len) + 2) >> 1) - 1), (dsPtr))) #endif -#endif #endif /* _TCLPLATDECLS */ diff --git a/generic/tclPosixStr.c b/generic/tclPosixStr.c index ceddddd..a65256d 100644 --- a/generic/tclPosixStr.c +++ b/generic/tclPosixStr.c @@ -382,7 +382,8 @@ Tcl_ErrnoId(void) #ifdef EOTHER case EOTHER: return "EOTHER"; #endif -#if defined(EOVERFLOW) && (!defined(EFBIG) || (EOVERFLOW != EFBIG)) && (!defined(EINVAL) || (EOVERFLOW != EINVAL)) +#if defined(EOVERFLOW) && (!defined(EFBIG) || (EOVERFLOW != EFBIG)) \ + && (!defined(EINVAL) || (EOVERFLOW != EINVAL)) case EOVERFLOW: return "EOVERFLOW"; #endif #ifdef EOWNERDEAD @@ -875,7 +876,8 @@ Tcl_ErrnoMsg( #ifdef EOTHER case EOTHER: return "other error"; #endif -#if defined(EOVERFLOW) && (!defined(EFBIG) || (EOVERFLOW != EFBIG)) && (!defined(EINVAL) || (EOVERFLOW != EINVAL)) +#if defined(EOVERFLOW) && (!defined(EFBIG) || (EOVERFLOW != EFBIG)) \ + && (!defined(EINVAL) || (EOVERFLOW != EINVAL)) case EOVERFLOW: return "value too large for defined data type"; #endif #ifdef EOWNERDEAD @@ -1075,7 +1077,10 @@ Tcl_SignalId( #ifdef SIGKILL case SIGKILL: return "SIGKILL"; #endif -#if defined(SIGLOST) && (!defined(SIGIOT) || (SIGLOST != SIGIOT)) && (!defined(SIGURG) || (SIGLOST != SIGURG)) && (!defined(SIGPROF) || (SIGLOST != SIGPROF)) && (!defined(SIGIO) || (SIGLOST != SIGIO)) +#if defined(SIGLOST) && (!defined(SIGIOT) || (SIGLOST != SIGIOT)) && \ + (!defined(SIGURG) || (SIGLOST != SIGURG)) && \ + (!defined(SIGPROF) || (SIGLOST != SIGPROF)) && \ + (!defined(SIGIO) || (SIGLOST != SIGIO)) case SIGLOST: return "SIGLOST"; #endif #ifdef SIGPIPE @@ -1087,7 +1092,8 @@ Tcl_SignalId( #ifdef SIGPROF case SIGPROF: return "SIGPROF"; #endif -#if defined(SIGPWR) && (!defined(SIGXFSZ) || (SIGPWR != SIGXFSZ)) && (!defined(SIGLOST) || (SIGPWR != SIGLOST)) +#if defined(SIGPWR) && (!defined(SIGXFSZ) || (SIGPWR != SIGXFSZ)) && \ + (!defined(SIGLOST) || (SIGPWR != SIGLOST)) case SIGPWR: return "SIGPWR"; #endif #ifdef SIGQUIT @@ -1209,7 +1215,10 @@ Tcl_SignalMsg( #ifdef SIGKILL case SIGKILL: return "kill signal"; #endif -#if defined(SIGLOST) && (!defined(SIGIOT) || (SIGLOST != SIGIOT)) && (!defined(SIGURG) || (SIGLOST != SIGURG)) && (!defined(SIGPROF) || (SIGLOST != SIGPROF)) && (!defined(SIGIO) || (SIGLOST != SIGIO)) +#if defined(SIGLOST) && (!defined(SIGIOT) || (SIGLOST != SIGIOT)) && \ + (!defined(SIGURG) || (SIGLOST != SIGURG)) && \ + (!defined(SIGPROF) || (SIGLOST != SIGPROF)) && \ + (!defined(SIGIO) || (SIGLOST != SIGIO)) case SIGLOST: return "resource lost"; #endif #ifdef SIGPIPE @@ -1221,7 +1230,8 @@ Tcl_SignalMsg( #ifdef SIGPROF case SIGPROF: return "profiling alarm"; #endif -#if defined(SIGPWR) && (!defined(SIGXFSZ) || (SIGPWR != SIGXFSZ)) && (!defined(SIGLOST) || (SIGPWR != SIGLOST)) +#if defined(SIGPWR) && (!defined(SIGXFSZ) || (SIGPWR != SIGXFSZ)) && \ + (!defined(SIGLOST) || (SIGPWR != SIGLOST)) case SIGPWR: return "power-fail restart"; #endif #ifdef SIGQUIT diff --git a/generic/tclProc.c b/generic/tclProc.c index cc3d5fb..32d79b4 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -50,7 +50,6 @@ static int SetLambdaFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static Tcl_NRPostProc ApplyNR2; static Tcl_NRPostProc InterpProcNR2; -static Tcl_NRPostProc Uplevel_Callback; static Tcl_ObjCmdProc NRInterpProc; /* @@ -272,7 +271,7 @@ Tcl_ProcObjCmd( cfPtr->level = -1; cfPtr->type = contextPtr->type; - cfPtr->line = (Tcl_Size *)Tcl_Alloc(sizeof(Tcl_Size)); + cfPtr->line = (int *)Tcl_Alloc(sizeof(int)); cfPtr->line[0] = contextPtr->line[3]; cfPtr->nline = 1; cfPtr->framePtr = NULL; @@ -733,15 +732,15 @@ TclGetFrame( CallFrame **framePtrPtr) /* Store pointer to frame here (or NULL if * global frame indicated). */ { - int result; - Tcl_Obj obj; - - obj.bytes = (char *) name; - obj.length = strlen(name); - obj.typePtr = NULL; - result = TclObjGetFrame(interp, &obj, framePtrPtr); - TclFreeInternalRep(&obj); - return result; + int result; + Tcl_Obj obj; + + obj.bytes = (char *) name; + obj.length = strlen(name); + obj.typePtr = NULL; + result = TclObjGetFrame(interp, &obj, framePtrPtr); + TclFreeInternalRep(&obj); + return result; } /* @@ -761,7 +760,12 @@ TclGetFrame( * two things above (in this case, the lookup acts as if objPtr were * "1"). The variable pointed to by framePtrPtr is filled in with the * address of the desired frame (unless an error occurs, in which case it - * isn't modified). + * isn't modified); if passed in as NULL, it indicates that resolution of + * the frame is uninteresting; only parsing of the frame identifier is + * desired (and no write of the frame ref will be done). + * + * The parse-only mode is used by the bytecode compiler, which saves + * resolution of the frame to bytecode execution time. * * Side effects: * None. @@ -774,10 +778,12 @@ TclObjGetFrame( Tcl_Interp *interp, /* Interpreter in which to find frame. */ Tcl_Obj *objPtr, /* Object describing frame. */ CallFrame **framePtrPtr) /* Store pointer to frame here (or NULL if - * global frame indicated). */ + * global frame indicated); when NULL itself, + * no frame resolution is wanted. */ { Interp *iPtr = (Interp *) interp; - int curLevel, level, result; + int curLevel; + int result, level; const Tcl_ObjInternalRep *irPtr; const char *name = NULL; Tcl_WideInt w; @@ -833,6 +839,10 @@ TclObjGetFrame( } if (result != -1) { + if (framePtrPtr == NULL) { + // Not interested in resolving to an actual level yet. + return result; + } /* if relative current level */ if (result == 0) { if (!curLevel) { @@ -879,8 +889,8 @@ badLevel: *---------------------------------------------------------------------- */ -static int -Uplevel_Callback( +int +TclUplevelCallback( void *data[], Tcl_Interp *interp, int result) @@ -931,9 +941,7 @@ TclNRUplevelObjCmd( * is only one argument. This requires a TIP since currently a single * argument is interpreted as a level indicator if possible. */ - uplevelSyntax: - Tcl_WrongNumArgs(interp, 1, objv, "?level? command ?arg ...?"); - return TCL_ERROR; + goto uplevelSyntax; } else if (!TclHasStringRep(objv[1]) && objc == 2) { int status; Tcl_Size llength; @@ -965,7 +973,7 @@ TclNRUplevelObjCmd( } objv += result + 1; - havelevel: + havelevel: /* * Modify the interpreter state to execute in the given frame. @@ -985,7 +993,6 @@ TclNRUplevelObjCmd( TclArgumentGet(interp, objv[0], &invoker, &word); objPtr = objv[0]; - } else { /* * More than one argument: concatenate them together with spaces @@ -996,9 +1003,12 @@ TclNRUplevelObjCmd( objPtr = Tcl_ConcatObj(objc, objv); } - TclNRAddCallback(interp, Uplevel_Callback, savedVarFramePtr, NULL, NULL, + TclNRAddCallback(interp, TclUplevelCallback, savedVarFramePtr, NULL, NULL, NULL); return TclNREvalObjEx(interp, objPtr, 0, invoker, word); + uplevelSyntax: + Tcl_WrongNumArgs(interp, 1, objv, "?level? command ?arg ...?"); + return TCL_ERROR; } /* @@ -1645,7 +1655,7 @@ TclNRInterpProc( } return TclNRInterpProcCore(interp, objv[0], 1, &MakeProcError); } - + static int NRInterpProc( void *clientData, /* Record describing procedure to be @@ -1727,7 +1737,7 @@ TclNRInterpProcCore( } #if defined(TCL_COMPILE_DEBUG) - if (tclTraceExec >= 1) { + if (tclTraceExec >= TCL_TRACE_BYTECODE_EXEC_PROCS) { CallFrame *framePtr = iPtr->varFramePtr; Tcl_Size i; @@ -1970,7 +1980,7 @@ TclProcCompileProc( Tcl_HashEntry *hePtr; #ifdef TCL_COMPILE_DEBUG - if (tclTraceCompile >= 1) { + if (tclTraceCompile >= TCL_TRACE_BYTECODE_COMPILE_SUMMARY) { /* * Display a line summarizing the top level command we are about * to compile. @@ -2454,7 +2464,7 @@ SetLambdaFromAny( Interp *iPtr = (Interp *) interp; const char *name; Tcl_Obj *argsPtr, *bodyPtr, *nsObjPtr, **objv; - int isNew, result; + int result; Tcl_Size objc; CmdFrame *cfPtr = NULL; Proc *procPtr; @@ -2559,7 +2569,7 @@ SetLambdaFromAny( if (contextPtr->line && (contextPtr->nline >= 2) && (contextPtr->line[1] >= 0)) { - Tcl_Size buf[2]; + int buf[2]; /* * Move from approximation (line of list cmd word) to actual @@ -2571,7 +2581,7 @@ SetLambdaFromAny( cfPtr->level = -1; cfPtr->type = contextPtr->type; - cfPtr->line = (Tcl_Size *)Tcl_Alloc(sizeof(Tcl_Size)); + cfPtr->line = (int *)Tcl_Alloc(sizeof(int)); cfPtr->line[0] = buf[1]; cfPtr->nline = 1; cfPtr->framePtr = NULL; @@ -2594,7 +2604,7 @@ SetLambdaFromAny( TclStackFree(interp, contextPtr); } Tcl_SetHashValue(Tcl_CreateHashEntry(iPtr->linePBodyPtr, procPtr, - &isNew), cfPtr); + NULL), cfPtr); /* * Set the namespace for this lambda: given by objv[2] understood as a diff --git a/generic/tclProcess.c b/generic/tclProcess.c index 8a592cd..9f4b849 100644 --- a/generic/tclProcess.c +++ b/generic/tclProcess.c @@ -26,7 +26,7 @@ static int autopurge = 1; /* Autopurge flag. */ typedef struct ProcessInfo { Tcl_Pid pid; /* Process id. */ - int resolvedPid; /* Resolved process id. */ + Tcl_Size resolvedPid; /* Resolved process id. */ int purge; /* Purge eventualy. */ TclProcessWaitStatus status;/* Process status. */ int code; /* Error code, exit status or signal @@ -859,7 +859,7 @@ TclProcessCreated( Tcl_SetHashValue(entry, info); entry = Tcl_CreateHashEntry(&infoTablePerResolvedPid, INT2PTR(resolvedPid), - &isNew); + NULL); Tcl_SetHashValue(entry, info); Tcl_MutexUnlock(&infoTablesMutex); diff --git a/generic/tclRegexp.c b/generic/tclRegexp.c index b1467cc..1bb7aee 100644 --- a/generic/tclRegexp.c +++ b/generic/tclRegexp.c @@ -863,7 +863,8 @@ CompileRegexp( { TclRegexp *regexpPtr; const Tcl_UniChar *uniString; - int numChars, status, i, exact; + int status, i, exact; + Tcl_Size numChars; Tcl_DString stringBuf; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); diff --git a/generic/tclResolve.c b/generic/tclResolve.c index e8023c4..16872cc 100644 --- a/generic/tclResolve.c +++ b/generic/tclResolve.c @@ -65,7 +65,7 @@ Tcl_AddInterpResolvers( { Interp *iPtr = (Interp *) interp; ResolverScheme *resPtr; - unsigned len; + size_t len; /* * Since we're adding a new name resolution scheme, we must force all code diff --git a/generic/tclResult.c b/generic/tclResult.c index 1cf3910..0b69165 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -853,7 +853,7 @@ ExpandedOptions( int TclMergeReturnOptions( Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ + Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[], /* Argument objects. */ Tcl_Obj **optionsPtrPtr, /* If not NULL, points to space for a (Tcl_Obj * *) where the pointer to the merged return diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index fbb2184..e1763a8 100644 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -592,11 +592,11 @@ TclParseNumber( * example: 5___6 */ for (before = (p - 1); - (before && *before == '_'); - before = (before > p ? (before - 1) : NULL)); + (before && *before == '_'); + before = (before > p ? (before - 1) : NULL)); for (after = (p + 1); - (after && *after && *after == '_'); - after = (*after && *after == '_') ? (after + 1) : NULL); + (after && *after && *after == '_'); + after = (*after && *after == '_') ? (after + 1) : NULL); switch (state) { case ZERO_B: diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 19cda6f..c33860d 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -177,7 +177,7 @@ GrowUnicodeBuffer( /* Note STRING_MAXCHARS already takes into account space for nul */ if (needed > STRING_MAXCHARS) { Tcl_Panic("max size for a Tcl unicode rep (%" TCL_Z_MODIFIER "d bytes) exceeded", - STRING_MAXCHARS); + STRING_MAXCHARS); } if (stringPtr->maxChars > 0) { /* Expansion - try allocating extra space */ @@ -306,7 +306,10 @@ Tcl_DbNewStringObj( length = (bytes? strlen(bytes) : 0); } TclDbNewObj(objPtr, file, line); - TclInitStringRep(objPtr, bytes, length); + if (!TclAttemptInitStringRep(objPtr, bytes, length)) { + Tcl_Panic("Failed to allocate %" TCL_SIZE_MODIFIER + "d bytes. %s:%d", length, file, line); + } return objPtr; } #else /* if not TCL_MEM_DEBUG */ @@ -645,7 +648,7 @@ TclGetUniChar( */ #undef Tcl_GetUnicodeFromObj -#if !defined(TCL_NO_DEPRECATED) +#ifndef TCL_NO_DEPRECATED Tcl_UniChar * TclGetUnicodeFromObj( Tcl_Obj *objPtr, /* The object to find the Unicode string @@ -673,7 +676,7 @@ TclGetUnicodeFromObj( } return stringPtr->unicode; } -#endif /* !defined(TCL_NO_DEPRECATED) */ +#endif /* !TCL_NO_DEPRECATED */ Tcl_UniChar * Tcl_GetUnicodeFromObj( @@ -2565,8 +2568,8 @@ Tcl_AppendFormatToObj( } default: if (interp != NULL) { - Tcl_SetObjResult(interp, - Tcl_ObjPrintf("bad field specifier \"%c\"", ch)); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad field specifier \"%c\"", ch)); Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADTYPE", (char *)NULL); } goto error; @@ -4372,6 +4375,49 @@ ExtendUnicodeRepWithString( } *dst = 0; } + +/* + *---------------------------------------------------------------------- + * + * Tcl_IsEmpty -- + * + * Check whether the obj is the empty string. + * + * Results: + * 1 if the obj is "" + * 0 otherwise + * + * Side effects: + * If there is no other way to determine whethere the string + * representation is the empty string, the string representation + * is generated. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_IsEmpty( + Tcl_Obj *objPtr) +{ + if (objPtr == NULL) { + Tcl_Panic("%s: objPtr is NULL", "Tcl_IsEmpty"); + } + if (!objPtr->bytes) { + if (TclHasInternalRep(objPtr, &tclDictType)) { + /* Since "dict" doesn't have a lengthProc */ + Tcl_Size size; + Tcl_DictObjSize(NULL, objPtr, &size); + return !size; + } + + Tcl_ObjTypeLengthProc *proc = TclObjTypeHasProc(objPtr, lengthProc); + if (proc != NULL) { + return !proc(objPtr); + } + (void)TclGetString(objPtr); + } + return !objPtr->length; +} /* *---------------------------------------------------------------------- diff --git a/generic/tclStringRep.h b/generic/tclStringRep.h index a7bca14..131523b 100644 --- a/generic/tclStringRep.h +++ b/generic/tclStringRep.h @@ -66,7 +66,7 @@ typedef struct { ((objPtr)->internalRep.twoPtrValue.ptr2 = NULL), \ ((objPtr)->internalRep.twoPtrValue.ptr1 = (void *) (stringPtr)) -#endif /* _TCLSTRINGREP */ +#endif /* _TCLSTRINGREP */ /* * Local Variables: * mode: c diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index c83410e..7793df8 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -39,26 +39,13 @@ #undef Tcl_DbNewLongObj #undef Tcl_NewObj #undef Tcl_NewStringObj -#undef Tcl_GetUnicode -#undef Tcl_GetUnicodeFromObj -#undef Tcl_NewUnicodeObj -#undef Tcl_SetUnicodeObj #undef Tcl_DumpActiveMemory #undef Tcl_ValidateAllMemory -#undef Tcl_FindHashEntry -#undef Tcl_CreateHashEntry -#undef Tcl_Panic #undef Tcl_FindExecutable -#undef Tcl_SetExitProc -#undef Tcl_SetPanicProc #undef TclpGetPid #undef TclSockMinimumBuffers #undef Tcl_SetIntObj #undef Tcl_SetLongObj -#undef Tcl_ListObjGetElements -#undef Tcl_ListObjLength -#undef Tcl_DictObjSize -#undef Tcl_SplitList #undef Tcl_SplitPath #undef Tcl_FSSplitPath #undef Tcl_ParseArgsObjv @@ -70,7 +57,7 @@ # define Tcl_WinConvertError 0 #endif #undef TclGetStringFromObj -#if defined(TCL_NO_DEPRECATED) +#ifdef TCL_NO_DEPRECATED # define TclGetStringFromObj 0 # define TclGetBytesFromObj 0 # define TclGetUnicodeFromObj 0 @@ -86,7 +73,7 @@ #undef TclListObjGetElements #undef TclListObjLength -#if defined(TCL_NO_DEPRECATED) +#ifdef TCL_NO_DEPRECATED # define TclListObjGetElements 0 # define TclListObjLength 0 # define TclDictObjSize 0 @@ -95,7 +82,7 @@ # define TclFSSplitPath 0 # define TclParseArgsObjv 0 # define TclGetAliasObj 0 -#else /* !defined(TCL_NO_DEPRECATED) */ +#else /* !TCL_NO_DEPRECATED */ int TclListObjGetElements(Tcl_Interp *interp, Tcl_Obj *listPtr, void *objcPtr, Tcl_Obj ***objvPtr) { Tcl_Size n = TCL_INDEX_NONE; @@ -205,18 +192,7 @@ int TclGetAliasObj(Tcl_Interp *interp, const char *childCmd, } return result; } -#endif /* !defined(TCL_NO_DEPRECATED) */ - -#define Tcl_CreateHashEntry createHashEntry -static Tcl_HashEntry * -Tcl_CreateHashEntry( - Tcl_HashTable *tablePtr, - const void *key, - int *newPtr) -{ - return (*((tablePtr)->createProc))(tablePtr, (const char *)(key), newPtr); -} - +#endif /* !TCL_NO_DEPRECATED */ #define TclBN_mp_add mp_add #define TclBN_mp_add_d mp_add_d @@ -861,9 +837,9 @@ const TclStubs tclStubs = { Tcl_DbNewStringObj, /* 28 */ Tcl_DuplicateObj, /* 29 */ TclFreeObj, /* 30 */ - Tcl_GetBoolean, /* 31 */ - Tcl_GetBooleanFromObj, /* 32 */ - Tcl_GetByteArrayFromObj, /* 33 */ + 0, /* 31 */ + 0, /* 32 */ + 0, /* 33 */ Tcl_GetDouble, /* 34 */ Tcl_GetDoubleFromObj, /* 35 */ 0, /* 36 */ @@ -911,7 +887,7 @@ const TclStubs tclStubs = { Tcl_BadChannelOption, /* 78 */ Tcl_CallWhenDeleted, /* 79 */ Tcl_CancelIdleCall, /* 80 */ - Tcl_Close, /* 81 */ + 0, /* 81 */ Tcl_CommandComplete, /* 82 */ Tcl_Concat, /* 83 */ Tcl_ConvertElement, /* 84 */ @@ -1170,7 +1146,7 @@ const TclStubs tclStubs = { Tcl_UtfToUpper, /* 337 */ Tcl_WriteChars, /* 338 */ Tcl_WriteObj, /* 339 */ - Tcl_GetString, /* 340 */ + 0, /* 340 */ 0, /* 341 */ 0, /* 342 */ Tcl_AlertNotifier, /* 343 */ @@ -1251,7 +1227,7 @@ const TclStubs tclStubs = { Tcl_IsChannelExisting, /* 418 */ 0, /* 419 */ 0, /* 420 */ - 0, /* 421 */ + Tcl_DbCreateHashEntry, /* 421 */ Tcl_CreateHashEntry, /* 422 */ Tcl_InitCustomHashTable, /* 423 */ Tcl_InitObjHashTable, /* 424 */ @@ -1520,7 +1496,12 @@ const TclStubs tclStubs = { Tcl_UtfNcasecmp, /* 687 */ Tcl_NewWideUIntObj, /* 688 */ Tcl_SetWideUIntObj, /* 689 */ - TclUnusedStubEntry, /* 690 */ + Tcl_IsEmpty, /* 690 */ + Tcl_GetEncodingNameForUser, /* 691 */ + Tcl_ListObjReverse, /* 692 */ + Tcl_ListObjRepeat, /* 693 */ + Tcl_ListObjRange, /* 694 */ + TclUnusedStubEntry, /* 695 */ }; /* !END!: Do not edit above this line. */ diff --git a/generic/tclTest.c b/generic/tclTest.c index 441b11f..ac5eee1 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -254,6 +254,7 @@ static Tcl_ObjCmdProc TestgetvarfullnameCmd; static Tcl_ObjCmdProc TestinterpdeleteCmd; static Tcl_ObjCmdProc TestlinkCmd; static Tcl_ObjCmdProc TestlinkarrayCmd; +static Tcl_ObjCmdProc TestlistapiCmd; static Tcl_ObjCmdProc TestlistrepCmd; static Tcl_ObjCmdProc TestlocaleCmd; static Tcl_ObjCmdProc TestmainthreadCmd; @@ -607,7 +608,7 @@ Tcltest_Init( Tcl_CreateObjCommand(interp, "testdelassocdata", TestdelassocdataCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testdoubledigits", TestdoubledigitsCmd, - NULL, NULL); + NULL, NULL); Tcl_DStringInit(&dstring); Tcl_CreateObjCommand(interp, "testdstring", TestdstringCmd, NULL, NULL); @@ -655,6 +656,7 @@ Tcltest_Init( NULL, NULL); Tcl_CreateObjCommand(interp, "testlink", TestlinkCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testlinkarray", TestlinkarrayCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "testlistapi", TestlistapiCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testlistrep", TestlistrepCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testlocale", TestlocaleCmd, NULL, NULL); @@ -847,9 +849,9 @@ Tcltest_SafeInit( static int TestasyncCmd( TCL_UNUSED(void *), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const *objv) /* Arguments. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const *objv) /* Arguments. */ { TestAsyncHandler *asyncPtr, *prevPtr; int id, code; @@ -963,14 +965,14 @@ TestasyncCmd( static int AsyncHandlerProc( - void *clientData, /* If of TestAsyncHandler structure. + void *clientData, /* If of TestAsyncHandler structure. * in global list. */ Tcl_Interp *interp, /* Interpreter in which command was * executed, or NULL. */ int code) /* Current return code from command. */ { TestAsyncHandler *asyncPtr; - int id = PTR2INT(clientData); + int id = (int)PTR2INT(clientData); const char *listArgv[4]; char *cmd; char string[TCL_INTEGER_SPACE]; @@ -1025,11 +1027,11 @@ AsyncHandlerProc( static Tcl_ThreadCreateType AsyncThreadProc( - void *clientData) /* Parameter is the id of a + void *clientData) /* Parameter is the id of a * TestAsyncHandler, defined above. */ { TestAsyncHandler *asyncPtr; - int id = PTR2INT(clientData); + int id = (int)PTR2INT(clientData); Tcl_Sleep(1); Tcl_MutexLock(&asyncTestMutex); @@ -1082,7 +1084,7 @@ static int Testcmdobj2Cmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ - Tcl_Size objc, /* Number of arguments. */ + Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Obj *resultObj; @@ -1119,10 +1121,10 @@ TestcmdinfoCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { static const char *const subcmds[] = { - "call", "call2", "create", "delete", "get", "modify", NULL + "call", "call2", "create", "delete", "get", "modify", NULL }; enum options { CMDINFO_CALL, CMDINFO_CALL2, CMDINFO_CREATE, @@ -1232,7 +1234,7 @@ TestcmdinfoCmd( static int CmdProc0( - void *clientData, /* String to return. */ + void *clientData, /* String to return. */ Tcl_Interp *interp, /* Current interpreter. */ TCL_UNUSED(int) /*objc*/, TCL_UNUSED(Tcl_Obj *const *) /*objv*/) @@ -1244,7 +1246,7 @@ CmdProc0( static int CmdProc1( - void *clientData, /* String to return. */ + void *clientData, /* String to return. */ Tcl_Interp *interp, /* Current interpreter. */ TCL_UNUSED(int) /*argc*/, TCL_UNUSED(const char **) /*argv*/) @@ -1255,7 +1257,7 @@ CmdProc1( static int CmdProc2( - void *clientData, /* String to return. */ + void *clientData, /* String to return. */ Tcl_Interp *interp, /* Current interpreter. */ TCL_UNUSED(int) /*argc*/, TCL_UNUSED(const char **) /*argv*/) @@ -1266,7 +1268,7 @@ CmdProc2( static void CmdDelProc0( - void *clientData) /* String to save. */ + void *clientData) /* String to save. */ { TestCommandTokenRef *thisRefPtr, *prevRefPtr = NULL; TestCommandTokenRef *refPtr = (TestCommandTokenRef *) clientData; @@ -1288,7 +1290,7 @@ CmdDelProc0( static void CmdDelProc1( - void *clientData) /* String to save. */ + void *clientData) /* String to save. */ { Tcl_DStringInit(&delString); Tcl_DStringAppend(&delString, "CmdDelProc1 ", -1); @@ -1297,7 +1299,7 @@ CmdDelProc1( static void CmdDelProc2( - void *clientData) /* String to save. */ + void *clientData) /* String to save. */ { Tcl_DStringInit(&delString); Tcl_DStringAppend(&delString, "CmdDelProc2 ", -1); @@ -1495,12 +1497,12 @@ TestcmdtraceCmd( static int CmdTraceProc( - void *clientData, /* Pointer to buffer in which the + void *clientData, /* Pointer to buffer in which the * command and arguments are appended. * Accumulates test result. */ TCL_UNUSED(Tcl_Interp *), TCL_UNUSED(int) /*level*/, - const char *command, /* The command being traced (after + const char *command, /* The command being traced (after * substitutions). */ TCL_UNUSED(Tcl_Command) /*cmdProc*/, int objc, /* Number of arguments. */ @@ -1601,7 +1603,7 @@ TestcreatecommandCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument strings. */ + Tcl_Obj *const objv[]) /* Argument strings. */ { if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "option"); @@ -1638,7 +1640,8 @@ CreatedCommandProc( found = Tcl_GetCommandInfo(interp, "test_ns_basic::createdcommand", &info); if (!found) { - Tcl_AppendResult(interp, "CreatedCommandProc could not get command info for test_ns_basic::createdcommand", + Tcl_AppendResult(interp, + "CreatedCommandProc could not get command info for test_ns_basic::createdcommand", (char *)NULL); return TCL_ERROR; } @@ -1659,7 +1662,8 @@ CreatedCommandProc2( found = Tcl_GetCommandInfo(interp, "value:at:", &info); if (!found) { - Tcl_AppendResult(interp, "CreatedCommandProc2 could not get command info for test_ns_basic::createdcommand", + Tcl_AppendResult(interp, + "CreatedCommandProc2 could not get command info for test_ns_basic::createdcommand", (char *)NULL); return TCL_ERROR; } @@ -1720,10 +1724,10 @@ TestdcallCmd( static void DelCallbackProc( - void *clientData, /* Numerical value to append to delString. */ + void *clientData, /* Numerical value to append to delString. */ Tcl_Interp *interp) /* Interpreter being deleted. */ { - int id = PTR2INT(clientData); + int id = (int)PTR2INT(clientData); char buffer[TCL_INTEGER_SPACE]; TclFormatInt(buffer, id); @@ -1782,7 +1786,7 @@ TestdelCmd( static int DelCmdProc( - void *clientData, /* String result to return. */ + void *clientData, /* String result to return. */ Tcl_Interp *interp, /* Current interpreter. */ TCL_UNUSED(int) /*objv*/, TCL_UNUSED(Tcl_Obj *const *) /*objv*/) @@ -1797,7 +1801,7 @@ DelCmdProc( static void DelDeleteProc( - void *clientData) /* String command to evaluate. */ + void *clientData) /* String command to evaluate. */ { DelCmd *dPtr = (DelCmd *)clientData; @@ -1997,7 +2001,15 @@ TestdstringCmd( if (strcmp(Tcl_GetString(objv[2]), "staticsmall") == 0) { Tcl_AppendResult(interp, "short", (char *)NULL); } else if (strcmp(Tcl_GetString(objv[2]), "staticlarge") == 0) { - 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", (char *)NULL); + Tcl_AppendResult(interp, + "first0 first1 first2 first3 first4 first5 first6 first7 first8 first9\n" + "second0 second1 second2 second3 second4 second5 second6 second7 second8 second9\n" + "third0 third1 third2 third3 third4 third5 third6 third7 third8 third9\n" + "fourth0 fourth1 fourth2 fourth3 fourth4 fourth5 fourth6 fourth7 fourth8 fourth9\n" + "fifth0 fifth1 fifth2 fifth3 fifth4 fifth5 fifth6 fifth7 fifth8 fifth9\n" + "sixth0 sixth1 sixth2 sixth3 sixth4 sixth5 sixth6 sixth7 sixth8 sixth9\n" + "seventh0 seventh1 seventh2 seventh3 seventh4 seventh5 seventh6 seventh7 seventh8 seventh9\n", + (char *)NULL); } else if (strcmp(Tcl_GetString(objv[2]), "free") == 0) { char *s = (char *)Tcl_Alloc(100); strcpy(s, "This is a malloc-ed string"); @@ -2057,12 +2069,8 @@ TestdstringCmd( */ static void SpecialFree( -#if TCL_MAJOR_VERSION > 8 - void *blockPtr /* Block to free. */ -#else - char *blockPtr /* Block to free. */ -#endif -) { + void *blockPtr) /* Block to free. */ +{ Tcl_Free(((char *)blockPtr) - 16); } @@ -2200,11 +2208,10 @@ static int UtfExtWrapper( /* Caller should have specified the dest char limit */ Tcl_Obj *valueObj; if (dstCharsVar == NULL || - (valueObj = Tcl_ObjGetVar2(interp, dstCharsVar, NULL, 0)) == NULL - ) { + (valueObj = Tcl_ObjGetVar2(interp, dstCharsVar, NULL, 0)) == NULL) { Tcl_SetResult(interp, - "dstCharsVar must be specified with integer value if " - "TCL_ENCODING_CHAR_LIMIT set in flags.", TCL_STATIC); + "dstCharsVar must be specified with integer value if " + "TCL_ENCODING_CHAR_LIMIT set in flags.", TCL_STATIC); return TCL_ERROR; } if (Tcl_GetIntFromObj(interp, valueObj, &dstChars) != TCL_OK) { @@ -2225,10 +2232,10 @@ static int UtfExtWrapper( &dstWrote, dstCharsVar ? &dstChars : NULL); if (memcmp(bufPtr + bufLen - 4, "\xAB\xCD\xEF\xAB", 4)) { - Tcl_SetObjResult(interp, - Tcl_ObjPrintf("%s wrote past output buffer", - transformer == Tcl_ExternalToUtf ? - "Tcl_ExternalToUtf" : "Tcl_UtfToExternal")); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s wrote past output buffer", + transformer == Tcl_ExternalToUtf ? + "Tcl_ExternalToUtf" : "Tcl_UtfToExternal")); result = TCL_ERROR; } else if (result != TCL_ERROR) { Tcl_Obj *resultObjs[3]; @@ -2311,10 +2318,12 @@ TestencodingCmd( const char *string; TclEncoding *encodingPtr; static const char *const optionStrings[] = { - "create", "delete", "nullength", "Tcl_ExternalToUtf", "Tcl_UtfToExternal", NULL + "create", "delete", "nullength", "Tcl_ExternalToUtf", "Tcl_UtfToExternal", + "Tcl_GetEncodingNameFromEnvironment", "Tcl_GetEncodingNameForUser", NULL }; enum options { - ENC_CREATE, ENC_DELETE, ENC_NULLENGTH, ENC_EXTTOUTF, ENC_UTFTOEXT + ENC_CREATE, ENC_DELETE, ENC_NULLENGTH, ENC_EXTTOUTF, ENC_UTFTOEXT, + ENC_GETNAMEENV, ENC_GETNAMEUSER } index; if (objc < 2) { @@ -2388,13 +2397,32 @@ TestencodingCmd( return UtfExtWrapper(interp,Tcl_ExternalToUtf,objc,objv); case ENC_UTFTOEXT: return UtfExtWrapper(interp,Tcl_UtfToExternal,objc,objv); + case ENC_GETNAMEUSER: + case ENC_GETNAMEENV: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; + } + Tcl_DString ds; + string = (index == ENC_GETNAMEUSER + ? Tcl_GetEncodingNameForUser + : Tcl_GetEncodingNameFromEnvironment)(&ds); + /* Note not string compare, the actual pointer must be the same */ + if (string != Tcl_DStringValue(&ds)) { + Tcl_DStringFree(&ds); + Tcl_SetResult(interp, "Returned pointer not same as DString value", + TCL_STATIC); + return TCL_ERROR; + } + Tcl_DStringResult(interp, &ds); + break; } return TCL_OK; } static int EncodingToUtfProc( - void *clientData, /* TclEncoding structure. */ + void *clientData, /* TclEncoding structure. */ TCL_UNUSED(const char *) /*src*/, int srcLen, /* Source string length in bytes. */ TCL_UNUSED(int) /*flags*/, @@ -2426,7 +2454,7 @@ EncodingToUtfProc( static int EncodingFromUtfProc( - void *clientData, /* TclEncoding structure. */ + void *clientData, /* TclEncoding structure. */ TCL_UNUSED(const char *) /*src*/, int srcLen, /* Source string length in bytes. */ TCL_UNUSED(int) /*flags*/, @@ -2458,7 +2486,7 @@ EncodingFromUtfProc( static void EncodingFreeProc( - void *clientData) /* ClientData associated with type. */ + void *clientData) /* ClientData associated with type. */ { TclEncoding *encodingPtr = (TclEncoding *)clientData; @@ -2717,7 +2745,7 @@ TesteventProc( static int TesteventDeleteProc( Tcl_Event *event, /* Event to examine */ - void *clientData) /* Tcl_Obj containing the name of the event(s) + void *clientData) /* Tcl_Obj containing the name of the event(s) * to remove */ { TestEvent *ev; /* Event to examine */ @@ -2790,7 +2818,7 @@ TestexithandlerCmd( static void ExitProcOdd( - void *clientData) /* Integer value to print. */ + void *clientData) /* Integer value to print. */ { char buf[16 + TCL_INTEGER_SPACE]; int len; @@ -2804,7 +2832,7 @@ ExitProcOdd( static void ExitProcEven( - void *clientData) /* Integer value to print. */ + void *clientData) /* Integer value to print. */ { char buf[16 + TCL_INTEGER_SPACE]; int len; @@ -3007,7 +3035,7 @@ TestexprstringCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *const *objv) /* Argument strings. */ + Tcl_Obj *const *objv) /* Argument strings. */ { if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "expression"); @@ -3679,9 +3707,9 @@ TestlinkCmd( static int TestlinkarrayCmd( TCL_UNUSED(void *), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { static const char *LinkOption[] = { "update", "remove", "create", NULL @@ -3798,9 +3826,9 @@ TestlinkarrayCmd( static int TestlistrepCmd( TCL_UNUSED(void *), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { /* Subcommands supported by this command */ static const char *const subcommands[] = { @@ -3859,12 +3887,12 @@ TestlistrepCmd( break; case LISTREP_DESCRIBE: -#define APPEND_FIELD(targetObj_, structPtr_, fld_) \ - do { \ - Tcl_ListObjAppendElement( \ - interp, (targetObj_), Tcl_NewStringObj(#fld_, -1)); \ - Tcl_ListObjAppendElement( \ - interp, (targetObj_), Tcl_NewWideIntObj((structPtr_)->fld_)); \ +#define APPEND_FIELD(targetObj_, structPtr_, fld_) \ + do { \ + Tcl_ListObjAppendElement(interp, (targetObj_), \ + Tcl_NewStringObj(#fld_, -1)); \ + Tcl_ListObjAppendElement(interp, (targetObj_), \ + Tcl_NewWideIntObj((structPtr_)->fld_)); \ } while (0) if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "object"); @@ -3935,6 +3963,190 @@ TestlistrepCmd( /* *---------------------------------------------------------------------- * + * TestlistapiCmd -- + * + * This function is invoked to test various public C API's to cover + * paths that are not exercisable via the script level commands. + * The general format is: + * testlistapi api refcount listoperand ?args ...? + * where api identifies the C function, refcount is the reference count + * to be set for the value listoperand passed into the list API. + * + * The result of the command is a dictionary of with the following + * elements (not all may be present, depending on the API called): + * status - the status returned by the API + * srcPtr - address of the Tcl_Obj passed into the API + * srcType - the Tcl_ObjType name of srcPtr + * srcRefCount - reference count of srcPtr *after* the API call + * resultPtr - address of the Tcl_Obj passed into the API + * resultType - the Tcl_ObjType name of resultPtr + * resultRefCount - reference count of resultPtr *after* the API call + * result - the resultPtr value + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestlistapiCmd( + TCL_UNUSED(void *), + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + static const char* const subcommands[] = { + "Tcl_ListObjRange", + "Tcl_ListObjRepeat", + "Tcl_ListObjReverse", + NULL + }; + enum listapiCmdIndex { + LISTAPI_RANGE, + LISTAPI_REPEAT, + LISTAPI_REVERSE, + } cmdIndex; + Tcl_Size srcRefCount; + Tcl_Obj *srcPtr; + Tcl_Obj *resultPtr = NULL; + int status; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "option ?arg...?"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[1], subcommands, "command", + 0, &cmdIndex) != TCL_OK) { + return TCL_ERROR; + } + if (cmdIndex == LISTAPI_REPEAT) { + srcRefCount = -1; /* Not relevant */ + srcPtr = NULL; + Tcl_Size repeatCount; + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, "repeatcount ?arg...?"); + return TCL_ERROR; + } + if (Tcl_GetSizeIntFromObj(interp, objv[2], &repeatCount) != TCL_OK) { + return TCL_ERROR; + } + status = Tcl_ListObjRepeat( + interp, repeatCount, objc - 3, objv + 3, &resultPtr); + } else { + if (objc < 4) { + Tcl_WrongNumArgs(interp, 2, objv, "refcount list ?arg...?"); + return TCL_ERROR; + } + if (Tcl_GetSizeIntFromObj(interp, objv[2], &srcRefCount) != TCL_OK) { + return TCL_ERROR; + } + srcPtr = Tcl_DuplicateObj(objv[3]); + for (Tcl_Size i = 0; i < srcRefCount; i++) { + Tcl_IncrRefCount(srcPtr); + } + switch (cmdIndex) { + case LISTAPI_RANGE: + if (objc != 6) { + Tcl_WrongNumArgs(interp, 2, objv, "refcount list start end"); + status = TCL_ERROR; + goto vamoose; /* To free up srcPtr */ + } + else { + Tcl_Size start, end; + if (Tcl_GetSizeIntFromObj(interp, objv[4], &start) != TCL_OK || + Tcl_GetSizeIntFromObj(interp, objv[5], &end) != TCL_OK) { + status = TCL_ERROR; + goto vamoose; /* To free up srcPtr */ + } + status = + Tcl_ListObjRange(interp, srcPtr, start, end, &resultPtr); + } + break; + case LISTAPI_REVERSE: + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "refcount list"); + status = TCL_ERROR; + goto vamoose; /* To free up srcPtr */ + } + status = Tcl_ListObjReverse(interp, srcPtr, &resultPtr); + break; + default: /* Keep gcc happy */ + Tcl_Panic("Unknown list API command %d", cmdIndex); + return TCL_ERROR; /* Not reached */ + } + } + +#define APPENDINT(name_, var_) \ + do { \ + Tcl_ListObjAppendElement( \ + NULL, objPtr, Tcl_NewStringObj((#name_), -1)); \ + Tcl_ListObjAppendElement( \ + NULL, objPtr, Tcl_NewWideIntObj((intptr_t)(var_))); \ + } while (0) +#define APPENDSTR(name_, var_) \ + do { \ + Tcl_ListObjAppendElement( \ + NULL, objPtr, Tcl_NewStringObj((#name_), -1)); \ + Tcl_ListObjAppendElement( \ + NULL, objPtr, Tcl_NewStringObj((var_), -1)); \ + } while (0) + + Tcl_Obj *objPtr = Tcl_NewListObj(0, NULL); + APPENDINT(status, status); + APPENDINT(srcPtr, srcPtr); + if (srcPtr) { + APPENDINT(srcRefCount, srcPtr->refCount); + if (srcPtr->typePtr && srcPtr->typePtr->name) { + APPENDSTR(srcType, srcPtr->typePtr->name); + } + else { + APPENDSTR(srcType, ""); + } + } + APPENDINT(resultPtr, resultPtr); + if (status == TCL_OK) { + if (resultPtr) { + APPENDINT(resultRefCount, resultPtr->refCount); + if (resultPtr->typePtr && resultPtr->typePtr->name) { + APPENDSTR(resultType, resultPtr->typePtr->name); + } + else { + APPENDSTR(resultType, ""); + } + Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewStringObj("result", -1)); + Tcl_ListObjAppendElement(NULL, objPtr, resultPtr); + } + } else { + Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewStringObj("result", -1)); + Tcl_ListObjAppendElement(NULL, objPtr, Tcl_GetObjResult(interp)); + status = TCL_OK; /* Irrespective of what Tcl_ListObj*() returned */ + } + Tcl_SetObjResult(interp, objPtr); + +vamoose: + if (srcPtr) { + if (srcRefCount == 0) { + /* The call made store internal refs so don't call Tcl_DecrRefCount */ + Tcl_BounceRefCount(srcPtr); + } else { + /* Decrement as many as we added */ + while (srcRefCount--) { + Tcl_DecrRefCount(srcPtr); + } + } + } + if (resultPtr) { + Tcl_BounceRefCount(resultPtr); + } + return status; +} + +/* + *---------------------------------------------------------------------- + * * TestlocaleCmd -- * * This procedure implements the "testlocale" command. It is used @@ -4012,7 +4224,7 @@ TestlocaleCmd( static void CleanupTestSetassocdataTests( - void *clientData, /* Data to be released. */ + void *clientData, /* Data to be released. */ TCL_UNUSED(Tcl_Interp *)) { Tcl_Free(clientData); @@ -4052,8 +4264,8 @@ TestmsbObjCmd( return TCL_ERROR; } if (w <= 0) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("argument must be positive",-1)); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "argument must be positive", -1)); return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewIntObj(TclMSB((unsigned long long)w))); @@ -4695,8 +4907,8 @@ TestregexpCmd( static void TestregexpXflags( - const char *string, /* The string of flags. */ - size_t length, /* The length of the string in bytes. */ + const char *string, /* The string of flags. */ + size_t length, /* The length of the string in bytes. */ int *cflagsPtr, /* compile flags word */ int *eflagsPtr) /* exec flags word */ { @@ -5080,7 +5292,8 @@ TestupvarCmd( } else if (strcmp(Tcl_GetString(objv[4]), "namespace") == 0) { flags = TCL_NAMESPACE_ONLY; } - return Tcl_UpVar2(interp, Tcl_GetString(objv[1]), Tcl_GetString(objv[2]), NULL, Tcl_GetString(objv[3]), flags); + return Tcl_UpVar2(interp, Tcl_GetString(objv[1]), Tcl_GetString(objv[2]), + NULL, Tcl_GetString(objv[3]), flags); } else { if (strcmp(Tcl_GetString(objv[5]), "global") == 0) { flags = TCL_GLOBAL_ONLY; @@ -5088,8 +5301,8 @@ TestupvarCmd( flags = TCL_NAMESPACE_ONLY; } return Tcl_UpVar2(interp, Tcl_GetString(objv[1]), Tcl_GetString(objv[2]), - (Tcl_GetString(objv[3])[0] == 0) ? NULL : Tcl_GetString(objv[3]), Tcl_GetString(objv[4]), - flags); + (Tcl_GetString(objv[3])[0] == 0) ? NULL : Tcl_GetString(objv[3]), + Tcl_GetString(objv[4]), flags); } } @@ -5130,16 +5343,20 @@ TestseterrorcodeCmd( Tcl_SetErrorCode(interp, Tcl_GetString(objv[1]), (char *)NULL); break; case 3: - Tcl_SetErrorCode(interp, Tcl_GetString(objv[1]), Tcl_GetString(objv[2]), (char *)NULL); + Tcl_SetErrorCode(interp, Tcl_GetString(objv[1]), Tcl_GetString(objv[2]), + (char *)NULL); break; case 4: - Tcl_SetErrorCode(interp, Tcl_GetString(objv[1]), Tcl_GetString(objv[2]), Tcl_GetString(objv[3]), (char *)NULL); + Tcl_SetErrorCode(interp, Tcl_GetString(objv[1]), Tcl_GetString(objv[2]), + Tcl_GetString(objv[3]), (char *)NULL); break; case 5: - Tcl_SetErrorCode(interp, Tcl_GetString(objv[1]), Tcl_GetString(objv[2]), Tcl_GetString(objv[3]), Tcl_GetString(objv[4]), (char *)NULL); + Tcl_SetErrorCode(interp, Tcl_GetString(objv[1]), Tcl_GetString(objv[2]), + Tcl_GetString(objv[3]), Tcl_GetString(objv[4]), (char *)NULL); break; case 6: - Tcl_SetErrorCode(interp, Tcl_GetString(objv[1]), Tcl_GetString(objv[2]), Tcl_GetString(objv[3]), Tcl_GetString(objv[4]), + Tcl_SetErrorCode(interp, Tcl_GetString(objv[1]), Tcl_GetString(objv[2]), + Tcl_GetString(objv[3]), Tcl_GetString(objv[4]), Tcl_GetString(objv[5]), (char *)NULL); } return TCL_ERROR; @@ -5812,7 +6029,7 @@ TestbytestringCmd( Tcl_Obj *const objv[]) /* The argument objects. */ { struct { -#if !defined(TCL_NO_DEPRECATED) +#ifndef TCL_NO_DEPRECATED int n; /* On purpose, not Tcl_Size, in order to demonstrate what happens */ #else Tcl_Size n; @@ -5858,12 +6075,12 @@ TestbytestringCmd( static int TestsetCmd( - void *data, /* Additional flags for Get/SetVar2. */ - Tcl_Interp *interp,/* Current interpreter. */ + void *data, /* Additional flags for Get/SetVar2. */ + Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* Arguments. */ { - int flags = PTR2INT(data); + int flags = (int)PTR2INT(data); const char *value; if (objc == 2) { @@ -5876,7 +6093,8 @@ TestsetCmd( return TCL_OK; } else if (objc == 3) { Tcl_AppendResult(interp, "before set", (char *)NULL); - value = Tcl_SetVar2(interp, Tcl_GetString(objv[1]), NULL, Tcl_GetString(objv[2]), flags); + value = Tcl_SetVar2(interp, Tcl_GetString(objv[1]), NULL, + Tcl_GetString(objv[2]), flags); if (value == NULL) { return TCL_ERROR; } @@ -5889,17 +6107,18 @@ TestsetCmd( } static int Testset2Cmd( - void *data, /* Additional flags for Get/SetVar2. */ - Tcl_Interp *interp,/* Current interpreter. */ + void *data, /* Additional flags for Get/SetVar2. */ + Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* Argument strings. */ { - int flags = PTR2INT(data); + int flags = (int)PTR2INT(data); const char *value; if (objc == 3) { Tcl_AppendResult(interp, "before get", (char *)NULL); - value = Tcl_GetVar2(interp, Tcl_GetString(objv[1]), Tcl_GetString(objv[2]), flags); + value = Tcl_GetVar2(interp, Tcl_GetString(objv[1]), + Tcl_GetString(objv[2]), flags); if (value == NULL) { return TCL_ERROR; } @@ -5907,7 +6126,8 @@ Testset2Cmd( return TCL_OK; } else if (objc == 4) { Tcl_AppendResult(interp, "before set", (char *)NULL); - value = Tcl_SetVar2(interp, Tcl_GetString(objv[1]), Tcl_GetString(objv[2]), Tcl_GetString(objv[3]), flags); + value = Tcl_SetVar2(interp, Tcl_GetString(objv[1]), Tcl_GetString(objv[2]), + Tcl_GetString(objv[3]), flags); if (value == NULL) { return TCL_ERROR; } @@ -5939,7 +6159,7 @@ Testset2Cmd( static int TestmainthreadCmd( TCL_UNUSED(void *), - Tcl_Interp *interp,/* Current interpreter. */ + Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const *objv) { @@ -6068,7 +6288,7 @@ TestChannelCmd( Channel *chanPtr; /* The actual channel. */ ChannelState *statePtr; /* state info for channel */ Tcl_Channel chan; /* The opaque type. */ - Tcl_Size len; /* Length of subcommand string. */ + Tcl_Size len; /* Length of subcommand string. */ int IOQueued; /* How much IO is queued inside channel? */ char buf[TCL_INTEGER_SPACE];/* For snprintf. */ int mode; /* rw mode of the channel */ @@ -6091,8 +6311,8 @@ TestChannelCmd( chan = (Tcl_Channel) NULL; for (nextPtrPtr = &firstDetached, curPtr = firstDetached; - curPtr != NULL; - nextPtrPtr = &(curPtr->nextPtr), curPtr = curPtr->nextPtr) { + curPtr != NULL; + nextPtrPtr = &(curPtr->nextPtr), curPtr = curPtr->nextPtr) { if (strcmp(Tcl_GetString(objv[2]), Tcl_GetChannelName(curPtr->chan)) == 0) { *nextPtrPtr = curPtr->nextPtr; @@ -6636,9 +6856,8 @@ TestChannelEventCmd( statePtr->scriptRecordPtr = esPtr->nextPtr; } else { for (prevEsPtr = statePtr->scriptRecordPtr; - (prevEsPtr != NULL) && - (prevEsPtr->nextPtr != esPtr); - prevEsPtr = prevEsPtr->nextPtr) { + (prevEsPtr != NULL) && (prevEsPtr->nextPtr != esPtr); + prevEsPtr = prevEsPtr->nextPtr) { /* Empty loop body. */ } if (prevEsPtr == NULL) { @@ -6768,7 +6987,7 @@ TestSocketCmd( Tcl_Obj *const *objv) /* Additional args. */ { const char *cmdName; /* Sub command. */ - Tcl_Size len; /* Length of subcommand string. */ + Tcl_Size len; /* Length of subcommand string. */ if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?additional args..?"); @@ -6883,7 +7102,7 @@ static int TestWrongNumArgsCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ - Tcl_Size objc, /* Number of arguments. */ + Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Size i, length; @@ -6955,12 +7174,14 @@ TestGetIndexFromObjStructCmd( return TCL_ERROR; } memset(idx, 85, sizeof(idx)); - if (Tcl_GetIndexFromObjStruct(interp, (Tcl_GetString(objv[1])[0] ? objv[1] : NULL), ary, 2*sizeof(char *), - "dummy", flags, &idx[1]) != TCL_OK) { + if (Tcl_GetIndexFromObjStruct(interp, (Tcl_GetString(objv[1])[0] ? objv[1] : NULL), + ary, 2*sizeof(char *), "dummy", flags, &idx[1]) != TCL_OK) { return TCL_ERROR; } if (idx[0] != 85 || idx[2] != 85) { - Tcl_AppendResult(interp, "Tcl_GetIndexFromObjStruct overwrites bytes near index variable", (char *)NULL); + Tcl_AppendResult(interp, + "Tcl_GetIndexFromObjStruct overwrites bytes near index variable", + (char *)NULL); return TCL_ERROR; } else if (idx[1] != target) { char buffer[64]; @@ -7664,8 +7885,7 @@ TestGetUniCharCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter */ int objc, /* Number of arguments */ - Tcl_Obj *const objv[] /* Argument strings */ - ) + Tcl_Obj *const objv[]) /* Argument strings */ { int index; int c ; @@ -7795,8 +8015,8 @@ TestcpuidCmd( } status = TclWinCPUID(index, regs); if (status != TCL_OK) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("operation not available", -1)); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "operation not available", -1)); return status; } for (i=0 ; i<4 ; ++i) { @@ -8048,8 +8268,8 @@ TestconcatobjCmd( * the end if no errors were found. */ - Tcl_SetObjResult(interp, - Tcl_NewStringObj("Tcl_ConcatObj is unsafe:", -1)); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "Tcl_ConcatObj is unsafe:", -1)); emptyPtr = Tcl_NewObj(); @@ -8407,11 +8627,9 @@ InterpCmdResolver( if ( (name[0] == 'z') && (name[1] == '\0') ) { Namespace *ns2NsPtr = (Namespace *) Tcl_FindNamespace(interp, "::ns2", NULL, 0); - if (procPtr != NULL - && ((procPtr->cmdPtr->nsPtr == iPtr->globalNsPtr) - || (ns2NsPtr != NULL && procPtr->cmdPtr->nsPtr == ns2NsPtr) - ) - ) { + if (procPtr != NULL && ( + (procPtr->cmdPtr->nsPtr == iPtr->globalNsPtr) + || (ns2NsPtr != NULL && procPtr->cmdPtr->nsPtr == ns2NsPtr))) { /* * Case A) * @@ -8493,7 +8711,7 @@ InterpVarResolver( } typedef struct MyResolvedVarInfo { - Tcl_ResolvedVarInfo vInfo; /* This must be the first element. */ + Tcl_ResolvedVarInfo vInfo; /* This must be the first element. */ Tcl_Var var; Tcl_Obj *nameObj; } MyResolvedVarInfo; @@ -8532,7 +8750,6 @@ MyCompiledVarFetch( { MyResolvedVarInfo *resVarInfo = (MyResolvedVarInfo *) vinfoPtr; Tcl_Var var = resVarInfo->var; - int isNewVar; Interp *iPtr = (Interp *) interp; Tcl_HashEntry *hPtr; @@ -8553,7 +8770,7 @@ MyCompiledVarFetch( } hPtr = Tcl_CreateHashEntry((Tcl_HashTable *) &iPtr->globalNsPtr->varTable, - resVarInfo->nameObj, &isNewVar); + resVarInfo->nameObj, NULL); if (hPtr) { var = (Tcl_Var) TclVarHashGetValue(hPtr); } else { @@ -8655,10 +8872,11 @@ TestInterpResolverCmd( * *------------------------------------------------------------------------ */ -int TestApplyLambdaCmd ( +int +TestApplyLambdaCmd( TCL_UNUSED(void*), - Tcl_Interp *interp, /* Current interpreter. */ - TCL_UNUSED(int), /* objc. */ + Tcl_Interp *interp, /* Current interpreter. */ + TCL_UNUSED(int), /* objc. */ TCL_UNUSED(Tcl_Obj *const *)) /* objv. */ { Tcl_Obj *lambdaObjs[2]; @@ -8744,10 +8962,10 @@ TestLutilCmd( Tcl_Obj **l1Elems; Tcl_Obj **l2Elems; static const char *const subcmds[] = { - "equal", "diffindex", NULL + "equal", "diffindex", NULL }; enum options { - LUTIL_EQUAL, LUTIL_DIFFINDEX + LUTIL_EQUAL, LUTIL_DIFFINDEX } idx; if (objc != 4) { diff --git a/generic/tclTestABSList.c b/generic/tclTestABSList.c index f74e224..7739b85 100644 --- a/generic/tclTestABSList.c +++ b/generic/tclTestABSList.c @@ -13,35 +13,23 @@ * Forward references */ -Tcl_Obj *myNewLStringObj(Tcl_WideInt start, - Tcl_WideInt length); +Tcl_Obj *myNewLStringObj(Tcl_WideInt start, Tcl_WideInt length); static void freeRep(Tcl_Obj* alObj); -static Tcl_Obj* my_LStringObjSetElem(Tcl_Interp *interp, - Tcl_Obj *listPtr, - Tcl_Size numIndcies, - Tcl_Obj *const indicies[], - Tcl_Obj *valueObj); +static Tcl_Obj* my_LStringObjSetElem(Tcl_Interp *interp, Tcl_Obj *listPtr, + Tcl_Size numIndcies, Tcl_Obj *const indicies[], Tcl_Obj *valueObj); static void DupLStringRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); static Tcl_Size my_LStringObjLength(Tcl_Obj *lstringObjPtr); -static int my_LStringObjIndex(Tcl_Interp *interp, - Tcl_Obj *lstringObj, - Tcl_Size index, - Tcl_Obj **charObjPtr); +static int my_LStringObjIndex(Tcl_Interp *interp, Tcl_Obj *lstringObj, + Tcl_Size index, Tcl_Obj **charObjPtr); static int my_LStringObjRange(Tcl_Interp *interp, Tcl_Obj *lstringObj, - Tcl_Size fromIdx, Tcl_Size toIdx, - Tcl_Obj **newObjPtr); + Tcl_Size fromIdx, Tcl_Size toIdx, Tcl_Obj **newObjPtr); static int my_LStringObjReverse(Tcl_Interp *interp, Tcl_Obj *srcObj, - Tcl_Obj **newObjPtr); -static int my_LStringReplace(Tcl_Interp *interp, - Tcl_Obj *listObj, - Tcl_Size first, - Tcl_Size numToDelete, - Tcl_Size numToInsert, - Tcl_Obj *const insertObjs[]); -static int my_LStringGetElements(Tcl_Interp *interp, - Tcl_Obj *listPtr, - Tcl_Size *objcptr, - Tcl_Obj ***objvptr); + Tcl_Obj **newObjPtr); +static int my_LStringReplace(Tcl_Interp *interp, Tcl_Obj *listObj, + Tcl_Size first, Tcl_Size numToDelete, Tcl_Size numToInsert, + Tcl_Obj *const insertObjs[]); +static int my_LStringGetElements(Tcl_Interp *interp, Tcl_Obj *listPtr, + Tcl_Size *objcptr, Tcl_Obj ***objvptr); static void lstringFreeElements(Tcl_Obj* lstringObj); static void UpdateStringOfLString(Tcl_Obj *objPtr); @@ -50,11 +38,11 @@ static void UpdateStringOfLString(Tcl_Obj *objPtr); */ typedef struct LString { - char *string; // NULL terminated utf-8 string - Tcl_Size strlen; // num bytes in string - Tcl_Size allocated; // num bytes allocated - Tcl_Obj**elements; // elements array, allocated when GetElements is - // called + char *string; // NULL terminated utf-8 string + Tcl_Size strlen; // num bytes in string + Tcl_Size allocated; // num bytes allocated + Tcl_Obj**elements; // elements array, allocated when GetElements is + // called } LString; /* @@ -268,18 +256,18 @@ my_LStringObjIndex( { LString *lstringRepPtr = (LString*)lstringObj->internalRep.twoPtrValue.ptr1; - (void)interp; + (void)interp; - if (index < lstringRepPtr->strlen) { - char cchar[2]; - cchar[0] = lstringRepPtr->string[index]; - cchar[1] = 0; - *charObjPtr = Tcl_NewStringObj(cchar,1); - } else { - *charObjPtr = NULL; - } + if (index < lstringRepPtr->strlen) { + char cchar[2]; + cchar[0] = lstringRepPtr->string[index]; + cchar[1] = 0; + *charObjPtr = Tcl_NewStringObj(cchar,1); + } else { + *charObjPtr = NULL; + } - return TCL_OK; + return TCL_OK; } @@ -301,7 +289,8 @@ my_LStringObjIndex( */ static Tcl_Size -my_LStringObjLength(Tcl_Obj *lstringObjPtr) +my_LStringObjLength( + Tcl_Obj *lstringObjPtr) { LString *lstringRepPtr = (LString *)lstringObjPtr->internalRep.twoPtrValue.ptr1; return lstringRepPtr->strlen; @@ -326,22 +315,24 @@ my_LStringObjLength(Tcl_Obj *lstringObjPtr) */ static void -DupLStringRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr) +DupLStringRep( + Tcl_Obj *srcPtr, + Tcl_Obj *copyPtr) { - LString *srcLString = (LString*)srcPtr->internalRep.twoPtrValue.ptr1; - LString *copyLString = (LString*)Tcl_Alloc(sizeof(LString)); - - memcpy(copyLString, srcLString, sizeof(LString)); - copyLString->string = (char*)Tcl_Alloc(srcLString->allocated); - strncpy(copyLString->string, srcLString->string, srcLString->strlen); - copyLString->string[srcLString->strlen] = '\0'; - copyLString->elements = NULL; - Tcl_ObjInternalRep itr; - itr.twoPtrValue.ptr1 = copyLString; - itr.twoPtrValue.ptr2 = NULL; - Tcl_StoreInternalRep(copyPtr, srcPtr->typePtr, &itr); - - return; + LString *srcLString = (LString*)srcPtr->internalRep.twoPtrValue.ptr1; + LString *copyLString = (LString*)Tcl_Alloc(sizeof(LString)); + + memcpy(copyLString, srcLString, sizeof(LString)); + copyLString->string = (char*)Tcl_Alloc(srcLString->allocated); + strncpy(copyLString->string, srcLString->string, srcLString->strlen); + copyLString->string[srcLString->strlen] = '\0'; + copyLString->elements = NULL; + Tcl_ObjInternalRep itr; + itr.twoPtrValue.ptr1 = copyLString; + itr.twoPtrValue.ptr2 = NULL; + Tcl_StoreInternalRep(copyPtr, srcPtr->typePtr, &itr); + + return; } /* @@ -378,8 +369,8 @@ my_LStringObjSetElem( Tcl_Obj *returnObj; if (numIndicies > 1) { - Tcl_SetObjResult(interp, - Tcl_ObjPrintf("Multiple indicies not supported by lstring.")); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "Multiple indicies not supported by lstring.")); return NULL; } @@ -430,7 +421,8 @@ my_LStringObjSetElem( *---------------------------------------------------------------------- */ -static int my_LStringObjRange( +static int +my_LStringObjRange( Tcl_Interp *interp, Tcl_Obj *lstringObj, Tcl_Size fromIdx, @@ -444,8 +436,7 @@ static int my_LStringObjRange( if (lstringRepPtr->strlen < fromIdx || lstringRepPtr->strlen < toIdx) { - Tcl_SetObjResult(interp, - Tcl_ObjPrintf("Range out of bounds ")); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("Range out of bounds ")); return TCL_ERROR; } @@ -493,7 +484,10 @@ static int my_LStringObjRange( */ static int -my_LStringObjReverse(Tcl_Interp *interp, Tcl_Obj *srcObj, Tcl_Obj **newObjPtr) +my_LStringObjReverse( + Tcl_Interp *interp, + Tcl_Obj *srcObj, + Tcl_Obj **newObjPtr) { LString *srcRep = (LString*)srcObj->internalRep.twoPtrValue.ptr1; Tcl_Obj *revObj; @@ -605,17 +599,17 @@ my_LStringReplace( } // move front elements to keep - for(x=0, kx=0; x<newLen && kx<first; kx++, x++) { + for (x=0, kx=0; x<newLen && kx<first; kx++, x++) { newStr[x] = oldStr[kx]; } // Insert new elements into new string - for(x=first, ix=0; ix<numToInsert; x++, ix++) { + for (x=first, ix=0; ix<numToInsert; x++, ix++) { char const *svalue = Tcl_GetString(insertObjs[ix]); newStr[x] = svalue[0]; } // Move remaining elements if ((first+numToDelete) < newLen) { - for(/*x,*/ kx=first+numToDelete; (kx <lstringRep->strlen && x<newLen); x++, kx++) { + for (/*x,*/ kx=first+numToDelete; (kx <lstringRep->strlen && x<newLen); x++, kx++) { newStr[x] = oldStr[kx]; } } @@ -638,7 +632,8 @@ my_LStringReplace( } static const Tcl_ObjType * -my_SetAbstractProc(int ptype) +my_SetAbstractProc( + int ptype) { const Tcl_ObjType *typePtr = &lstringTypes[0]; /* default value */ if (4 <= ptype && ptype <= 11) { @@ -738,7 +733,8 @@ my_NewLStringObj( */ static void -lstringFreeElements(Tcl_Obj* lstringObj) +lstringFreeElements( + Tcl_Obj* lstringObj) { LString *lstringRepPtr = (LString*)lstringObj->internalRep.twoPtrValue.ptr1; if (lstringRepPtr->elements) { @@ -768,7 +764,8 @@ lstringFreeElements(Tcl_Obj* lstringObj) */ static void -freeRep(Tcl_Obj* lstringObj) +freeRep( + Tcl_Obj* lstringObj) { LString *lstringRepPtr = (LString*)lstringObj->internalRep.twoPtrValue.ptr1; if (lstringRepPtr->string) { @@ -795,10 +792,12 @@ freeRep(Tcl_Obj* lstringObj) *---------------------------------------------------------------------- */ -static int my_LStringGetElements(Tcl_Interp *interp, - Tcl_Obj *lstringObj, - Tcl_Size *objcptr, - Tcl_Obj ***objvptr) +static int +my_LStringGetElements( + Tcl_Interp *interp, + Tcl_Obj *lstringObj, + Tcl_Size *objcptr, + Tcl_Obj ***objvptr) { LString *lstringRepPtr = (LString*)lstringObj->internalRep.twoPtrValue.ptr1; Tcl_Obj **objPtr; @@ -827,14 +826,15 @@ static int my_LStringGetElements(Tcl_Interp *interp, */ static void -UpdateStringOfLString(Tcl_Obj *objPtr) +UpdateStringOfLString( + Tcl_Obj *objPtr) { # define LOCAL_SIZE 64 int localFlags[LOCAL_SIZE], *flagPtr = NULL; Tcl_ObjType const *typePtr = objPtr->typePtr; char *p; - int bytesNeeded = 0; - int llen, i; + Tcl_Size bytesNeeded = 0; + Tcl_Size llen, i; /* @@ -925,21 +925,21 @@ lLStringObjCmd( int objc, Tcl_Obj * const objv[]) { - Tcl_Obj *lstringObj; + Tcl_Obj *lstringObj; - (void)clientData; - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "string"); - return TCL_ERROR; - } + (void)clientData; + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "string"); + return TCL_ERROR; + } - lstringObj = my_NewLStringObj(interp, objc-1, &objv[1]); + lstringObj = my_NewLStringObj(interp, objc-1, &objv[1]); - if (lstringObj) { - Tcl_SetObjResult(interp, lstringObj); - return TCL_OK; - } - return TCL_ERROR; + if (lstringObj) { + Tcl_SetObjResult(interp, lstringObj); + return TCL_OK; + } + return TCL_ERROR; } /* @@ -952,11 +952,11 @@ lLStringObjCmd( * Internal rep for the Generate Series */ typedef struct LgenSeries { - Tcl_Interp *interp; // used to evaluate gen script - Tcl_Size len; // list length - Tcl_Size nargs; // Number of arguments in genFn including "index" - Tcl_Obj *genFnObj; // The preformed command as a list. Index is set in - // the last element (last argument) + Tcl_Interp *interp; // used to evaluate gen script + Tcl_Size len; // list length + Tcl_Size nargs; // Number of arguments in genFn including "index" + Tcl_Obj *genFnObj; // The preformed command as a list. Index is set in + // the last element (last argument) } LgenSeries; /* @@ -996,7 +996,8 @@ lgen( * Abstract List Length function */ static Tcl_Size -lgenSeriesObjLength(Tcl_Obj *objPtr) +lgenSeriesObjLength( + Tcl_Obj *objPtr) { LgenSeries *lgenSeriesRepPtr = (LgenSeries *)objPtr->internalRep.twoPtrValue.ptr1; return lgenSeriesRepPtr->len; @@ -1042,7 +1043,8 @@ lgenSeriesObjIndex( */ static void -UpdateStringOfLgen(Tcl_Obj *objPtr) +UpdateStringOfLgen( + Tcl_Obj *objPtr) { LgenSeries *lgenSeriesRepPtr; Tcl_Obj *element; @@ -1074,7 +1076,8 @@ UpdateStringOfLgen(Tcl_Obj *objPtr) * ObjType Free Internal Rep function */ static void -FreeLgenInternalRep(Tcl_Obj *objPtr) +FreeLgenInternalRep( + Tcl_Obj *objPtr) { LgenSeries *lgenSeries = (LgenSeries*)objPtr->internalRep.twoPtrValue.ptr1; if (lgenSeries->genFnObj) { @@ -1211,8 +1214,6 @@ int Lgen_Init(Tcl_Interp *interp) { Tcl_PkgProvide(interp, "lgen", "1.0"); return TCL_OK; } - - /* *---------------------------------------------------------------------- @@ -1246,7 +1247,10 @@ int Lgen_Init(Tcl_Interp *interp) { *---------------------------------------------------------------------- */ -int Tcl_ABSListTest_Init(Tcl_Interp *interp) { +int +Tcl_ABSListTest_Init( + Tcl_Interp *interp) +{ if (Tcl_InitStubs(interp, "9.0-", 0) == NULL) { return TCL_ERROR; } diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index 4f5ba35..e2b1f6f 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -46,6 +46,7 @@ static Tcl_ObjCmdProc TestlistobjCmd; static Tcl_ObjCmdProc TestobjCmd; static Tcl_ObjCmdProc TeststringobjCmd; static Tcl_ObjCmdProc TestbigdataCmd; +static Tcl_ObjCmdProc TestisemptyCmd; #define VARPTR_KEY "TCLOBJTEST_VARPTR" #define NUMBER_OF_OBJECT_VARS 20 @@ -133,6 +134,8 @@ TclObjTest_Init( Tcl_CreateObjCommand(interp, "testobj", TestobjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "teststringobj", TeststringobjCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "testisempty", TestisemptyCmd, + NULL, NULL); if (sizeof(Tcl_Size) == sizeof(Tcl_WideInt)) { Tcl_CreateObjCommand(interp, "testbigdata", TestbigdataCmd, NULL, NULL); @@ -199,14 +202,14 @@ TestbignumobjCmd( } string = Tcl_GetString(objv[3]); if (mp_init(&bignumValue) != MP_OKAY) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("error in mp_init", -1)); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "error in mp_init", -1)); return TCL_ERROR; } if (mp_read_radix(&bignumValue, string, 10) != MP_OKAY) { mp_clear(&bignumValue); - Tcl_SetObjResult(interp, - Tcl_NewStringObj("error in mp_read_radix", -1)); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "error in mp_read_radix", -1)); return TCL_ERROR; } @@ -249,8 +252,8 @@ TestbignumobjCmd( } if (mp_mul_d(&bignumValue, 10, &bignumValue) != MP_OKAY) { mp_clear(&bignumValue); - Tcl_SetObjResult(interp, - Tcl_NewStringObj("error in mp_mul_d", -1)); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "error in mp_mul_d", -1)); return TCL_ERROR; } if (!Tcl_IsShared(varPtr[varIndex])) { @@ -274,8 +277,8 @@ TestbignumobjCmd( } if (mp_div_d(&bignumValue, 10, &bignumValue, NULL) != MP_OKAY) { mp_clear(&bignumValue); - Tcl_SetObjResult(interp, - Tcl_NewStringObj("error in mp_div_d", -1)); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "error in mp_div_d", -1)); return TCL_ERROR; } if (!Tcl_IsShared(varPtr[varIndex])) { @@ -299,8 +302,8 @@ TestbignumobjCmd( } if (mp_mod_2d(&bignumValue, 1, &bignumValue) != MP_OKAY) { mp_clear(&bignumValue); - Tcl_SetObjResult(interp, - Tcl_NewStringObj("error in mp_mod_2d", -1)); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "error in mp_mod_2d", -1)); return TCL_ERROR; } if (!Tcl_IsShared(varPtr[varIndex])) { @@ -590,7 +593,7 @@ TestindexobjCmd( */ struct IndexRep { void *tablePtr; /* Pointer to the table of strings. */ - Tcl_Size offset; /* Offset between table entries. */ + Tcl_Size offset; /* Offset between table entries. */ Tcl_Size index; /* Selected index into table. */ } *indexRep; @@ -918,8 +921,8 @@ TestlistobjCmd( } cmdIndex; Tcl_Size varIndex; /* Variable number converted to binary */ - Tcl_Size first; /* First index in the list */ - Tcl_Size count; /* Count of elements in a list */ + Tcl_Size first; /* First index in the list */ + Tcl_Size count; /* Count of elements in a list */ Tcl_Obj **varPtr; Tcl_Size i, len; @@ -1079,13 +1082,13 @@ static int V1TestListObjIndex( static const Tcl_ObjType v1TestListType = { "testlist", /* name */ - NULL, /* freeIntRepProc */ - NULL, /* dupIntRepProc */ - NULL, /* updateStringProc */ - NULL, /* setFromAnyProc */ - offsetof(Tcl_ObjType, indexProc), /* This is a V1 objType, which doesn't have an indexProc */ - V1TestListObjLength, /* always return 100, doesn't really matter */ - V1TestListObjIndex, /* should never be accessed, because this objType = V1*/ + NULL, /* freeIntRepProc */ + NULL, /* dupIntRepProc */ + NULL, /* updateStringProc */ + NULL, /* setFromAnyProc */ + offsetof(Tcl_ObjType, indexProc), /* This is a V1 objType, which doesn't have an indexProc */ + V1TestListObjLength, /* always return 100, doesn't really matter */ + V1TestListObjIndex, /* should never be accessed, because this objType = V1*/ NULL, NULL, NULL, NULL, NULL, NULL }; @@ -1104,6 +1107,7 @@ TestobjCmd( static const char *const subcommands[] = { "freeallvars", "bug3598580", "buge58d7e19e9", "types", "objtype", "newobj", "set", + "objrefcount", "assign", "convert", "duplicate", "invalidateStringRep", "refcount", "type", NULL @@ -1111,6 +1115,7 @@ TestobjCmd( enum testobjCmdIndex { TESTOBJ_FREEALLVARS, TESTOBJ_BUG3598580, TESTOBJ_BUGE58D7E19E9, TESTOBJ_TYPES, TESTOBJ_OBJTYPE, TESTOBJ_NEWOBJ, TESTOBJ_SET, + TESTOBJ_OBJREFCOUNT, TESTOBJ_ASSIGN, TESTOBJ_CONVERT, TESTOBJ_DUPLICATE, TESTOBJ_INVALIDATESTRINGREP, TESTOBJ_REFCOUNT, TESTOBJ_TYPE, } cmdIndex; @@ -1208,6 +1213,13 @@ TestobjCmd( } SetVarToObj(varPtr, varIndex, objv[3]); return TCL_OK; + case TESTOBJ_OBJREFCOUNT: + if (objc != 3) { + goto wrongNumArgs; + } else { + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(objv[2]->refCount)); + } + return TCL_OK; default: break; @@ -1490,7 +1502,7 @@ TeststringobjCmd( } Tcl_SetWideIntObj(Tcl_GetObjResult(interp), length); break; - case 10: { /* range */ + case 10: { /* range */ Tcl_Size first, last; if (objc != 5) { goto wrongNumArgs; @@ -1564,7 +1576,7 @@ TeststringobjCmd( Tcl_AppendUnicodeToObj(varPtr[varIndex], unicode + length, size - length); Tcl_SetObjResult(interp, varPtr[varIndex]); break; - case 13: /* newunicode*/ + case 13: /* newunicode*/ unicode = (Tcl_UniChar *)Tcl_Alloc((objc - 3) * sizeof(Tcl_UniChar)); for (i = 0; i < (objc - 3); ++i) { int val; @@ -1610,15 +1622,15 @@ TeststringobjCmd( static int TestbigdataCmd ( TCL_UNUSED(void *), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { static const char *const subcmds[] = { - "string", "bytearray", "list", "dict", NULL + "string", "bytearray", "list", "dict", NULL }; enum options { - BIGDATA_STRING, BIGDATA_BYTEARRAY, BIGDATA_LIST, BIGDATA_DICT + BIGDATA_STRING, BIGDATA_BYTEARRAY, BIGDATA_LIST, BIGDATA_DICT } idx; char *s; unsigned char *p; @@ -1667,7 +1679,7 @@ TestbigdataCmd ( Tcl_DStringSetLength(&ds, len);/* Also stores \0 at index len+1 */ s = Tcl_DStringValue(&ds); for (i = 0; i < len; ++i) { - s[i] = '0' + (i % PATTERN_LEN); + s[i] = '0' + (char)(i % PATTERN_LEN); } if (split >= 0) { assert(split < len); @@ -1679,7 +1691,7 @@ TestbigdataCmd ( objPtr = Tcl_NewByteArrayObj(NULL, len); p = Tcl_GetByteArrayFromObj(objPtr, &len); for (i = 0; i < len; ++i) { - p[i] = '0' + (i % PATTERN_LEN); + p[i] = (char)('0' + (i % PATTERN_LEN)); } if (split >= 0) { assert(split < len); @@ -1828,6 +1840,30 @@ CheckIfVarUnset( return 0; } +static int +TestisemptyCmd ( + TCL_UNUSED(void *), + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_Obj *result; + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "value"); + return TCL_ERROR; + } + result = Tcl_NewIntObj(Tcl_IsEmpty(objv[1])); + if (!objv[1]->bytes) { + Tcl_AppendToObj(result, " pure", TCL_INDEX_NONE); + } + if (objv[1]->typePtr) { + Tcl_AppendToObj(result, " ", TCL_INDEX_NONE); + Tcl_AppendToObj(result, objv[1]->typePtr->name, TCL_INDEX_NONE); + } + Tcl_SetObjResult(interp, result); + return TCL_OK; +} + /* * Local Variables: * mode: c diff --git a/generic/tclTestProcBodyObj.c b/generic/tclTestProcBodyObj.c index 0fedde8..e6cb48c 100644 --- a/generic/tclTestProcBodyObj.c +++ b/generic/tclTestProcBodyObj.c @@ -38,7 +38,7 @@ static const char checkCommand[] = "check"; */ typedef struct { - const char *cmdName; /* command name */ + const char *cmdName; /* command name */ Tcl_ObjCmdProc *proc; /* command proc */ int exportIt; /* if 1, export the command */ } CmdTable; diff --git a/generic/tclThread.c b/generic/tclThread.c index c107780..dbd3ecd 100644 --- a/generic/tclThread.c +++ b/generic/tclThread.c @@ -23,9 +23,9 @@ */ typedef struct { - int num; /* Number of objects remembered */ - int max; /* Max size of the array */ - void **list; /* List of pointers */ + int num; /* Number of objects remembered */ + int max; /* Max size of the array */ + void **list; /* List of pointers */ } SyncObjRecord; static SyncObjRecord keyRecord = {0, 0, NULL}; @@ -109,7 +109,6 @@ Tcl_GetThreadData( void * TclThreadDataKeyGet( Tcl_ThreadDataKey *keyPtr) /* Identifier for the data chunk. */ - { #if TCL_THREADS return TclThreadStorageKeyGet(keyPtr); diff --git a/generic/tclThreadAlloc.c b/generic/tclThreadAlloc.c index 152b43d..d4178cd 100644 --- a/generic/tclThreadAlloc.c +++ b/generic/tclThreadAlloc.c @@ -92,7 +92,7 @@ typedef struct { size_t numRemoves; /* Number of removes from bucket */ size_t numInserts; /* Number of inserts into bucket */ size_t numLocks; /* Number of locks acquired */ - size_t totalAssigned; /* Total space assigned to bucket */ + size_t totalAssigned; /* Total space assigned to bucket */ } Bucket; /* diff --git a/generic/tclThreadStorage.c b/generic/tclThreadStorage.c index 22dd0c3..3d79407 100644 --- a/generic/tclThreadStorage.c +++ b/generic/tclThreadStorage.c @@ -48,7 +48,7 @@ static struct { */ typedef struct { - void **tablePtr; /* The table of Tcl TSDs. */ + void **tablePtr; /* The table of Tcl TSDs. */ sig_atomic_t allocated; /* The size of the table in the current * thread. */ } TSDTable; diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c index faaf92a..349830b 100644 --- a/generic/tclThreadTest.c +++ b/generic/tclThreadTest.c @@ -101,7 +101,6 @@ typedef struct ThreadEventResult { struct ThreadEvent *eventPtr; /* Back pointer */ struct ThreadEventResult *nextPtr; /* List for cleanup */ struct ThreadEventResult *prevPtr; - } ThreadEventResult; static ThreadEventResult *resultList; diff --git a/generic/tclTimer.c b/generic/tclTimer.c index 86c1f2c..8a418a3 100644 --- a/generic/tclTimer.c +++ b/generic/tclTimer.c @@ -21,7 +21,7 @@ typedef struct TimerHandler { Tcl_Time time; /* When timer is to fire. */ Tcl_TimerProc *proc; /* Function to call. */ - void *clientData; /* Argument to pass to proc. */ + void *clientData; /* Argument to pass to proc. */ Tcl_TimerToken token; /* Identifies handler so it can be deleted. */ struct TimerHandler *nextPtr; /* Next event in queue, or NULL for end of @@ -65,6 +65,9 @@ typedef struct AfterAssocData { * none. */ } AfterAssocData; +/* Associated data key used to look up the AfterAssocData for an interp. */ +#define ASSOC_KEY "tclAfter" + /* * There is one of the following structures for each of the handlers declared * in a call to Tcl_DoWhenIdle. All of the currently-active handlers are @@ -73,7 +76,7 @@ typedef struct AfterAssocData { typedef struct IdleHandler { Tcl_IdleProc *proc; /* Function to call. */ - void *clientData; /* Value to pass to proc. */ + void *clientData; /* Value to pass to proc. */ int generation; /* Used to distinguish older handlers from * recently-created ones. */ struct IdleHandler *nextPtr;/* Next in list of active handlers. */ @@ -251,7 +254,7 @@ Tcl_CreateTimerHandler( int milliseconds, /* How many milliseconds to wait before * invoking proc. */ Tcl_TimerProc *proc, /* Function to invoke. */ - void *clientData) /* Arbitrary data to pass to proc. */ + void *clientData) /* Arbitrary data to pass to proc. */ { Tcl_Time time; @@ -619,7 +622,7 @@ TimerHandlerEventProc( void Tcl_DoWhenIdle( Tcl_IdleProc *proc, /* Function to invoke. */ - void *clientData) /* Arbitrary value to pass to proc. */ + void *clientData) /* Arbitrary value to pass to proc. */ { IdleHandler *idlePtr; Tcl_Time blockTime; @@ -663,7 +666,7 @@ Tcl_DoWhenIdle( void Tcl_CancelIdleCall( Tcl_IdleProc *proc, /* Function that was previously registered. */ - void *clientData) /* Arbitrary value to pass to proc. */ + void *clientData) /* Arbitrary value to pass to proc. */ { IdleHandler *idlePtr, *prevPtr; IdleHandler *nextPtr; @@ -805,12 +808,12 @@ Tcl_AfterObjCmd( * doesn't already exist. */ - assocPtr = (AfterAssocData *)Tcl_GetAssocData(interp, "tclAfter", NULL); + assocPtr = (AfterAssocData *)Tcl_GetAssocData(interp, ASSOC_KEY, NULL); if (assocPtr == NULL) { assocPtr = (AfterAssocData *)Tcl_Alloc(sizeof(AfterAssocData)); assocPtr->interp = interp; assocPtr->firstAfterPtr = NULL; - Tcl_SetAssocData(interp, "tclAfter", AfterCleanupProc, assocPtr); + Tcl_SetAssocData(interp, ASSOC_KEY, AfterCleanupProc, assocPtr); } /* @@ -1115,7 +1118,7 @@ GetAfterEvent( return NULL; } cmdString += 6; - id = strtoul(cmdString, &end, 10); + id = (int)strtoul(cmdString, &end, 10); if ((end == cmdString) || (*end != 0)) { return NULL; } @@ -1149,7 +1152,7 @@ GetAfterEvent( static void AfterProc( - void *clientData) /* Describes command to execute. */ + void *clientData) /* Describes command to execute. */ { AfterInfo *afterPtr = (AfterInfo *)clientData; AfterAssocData *assocPtr = afterPtr->assocPtr; @@ -1214,7 +1217,7 @@ AfterProc( static void FreeAfterPtr( - AfterInfo *afterPtr) /* Command to be deleted. */ + AfterInfo *afterPtr) /* Command to be deleted. */ { AfterInfo *prevPtr; AfterAssocData *assocPtr = afterPtr->assocPtr; @@ -1251,7 +1254,7 @@ FreeAfterPtr( static void AfterCleanupProc( - void *clientData, /* Points to AfterAssocData for the + void *clientData, /* Points to AfterAssocData for the * interpreter. */ TCL_UNUSED(Tcl_Interp *)) { diff --git a/generic/tclTrace.c b/generic/tclTrace.c index e43eba8..05eb7e2 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -22,7 +22,7 @@ typedef struct { int flags; /* Operations for which Tcl command is to be * invoked. */ Tcl_Size length; /* Number of non-NUL chars. in command. */ - char command[TCLFLEXARRAY]; /* Space for Tcl command to invoke. Actual + char command[TCLFLEXARRAY]; /* Space for Tcl command to invoke. Actual * size will be as large as necessary to hold * command. This field must be the last in the * structure, so that it can be larger than 1 @@ -44,7 +44,7 @@ typedef struct { Tcl_Size length; /* Number of non-NUL chars. in command. */ Tcl_Trace stepTrace; /* Used for execution traces, when tracing * inside the given command */ - Tcl_Size startLevel; /* Used for bookkeeping with step execution + Tcl_Size startLevel; /* Used for bookkeeping with step execution * traces, store the level at which the step * trace was invoked */ char *startCmd; /* Used for bookkeeping with step execution @@ -56,7 +56,7 @@ typedef struct { * deleted too early. Keeps track of how many * pieces of code have a pointer to this * structure. */ - char command[TCLFLEXARRAY]; /* Space for Tcl command to invoke. Actual + char command[TCLFLEXARRAY]; /* Space for Tcl command to invoke. Actual * size will be as large as necessary to hold * command. This field must be the last in the * structure, so that it can be larger than 1 @@ -81,21 +81,22 @@ typedef struct { * an internal trace. * The flag 'TCL_TRACE_DESTROYED' may also be used in command execution traces. */ - -#define TCL_TRACE_ENTER_DURING_EXEC 4 -#define TCL_TRACE_LEAVE_DURING_EXEC 8 -#define TCL_TRACE_ANY_EXEC 15 -#define TCL_TRACE_EXEC_IN_PROGRESS 0x10 -#define TCL_TRACE_EXEC_DIRECT 0x20 +enum TraceCommandInfoFlags { + TCL_TRACE_ENTER_DURING_EXEC = TCL_TRACE_ENTER_EXEC << 2, + TCL_TRACE_LEAVE_DURING_EXEC = TCL_TRACE_LEAVE_EXEC << 2, + TCL_TRACE_ANY_EXEC = 15, + TCL_TRACE_EXEC_IN_PROGRESS = 0x10, + TCL_TRACE_EXEC_DIRECT = 0x20 +}; /* * Forward declarations for functions defined in this file: */ -enum traceOptionsEnum { +typedef enum TraceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE -}; -typedef int (Tcl_TraceTypeObjCmd)(Tcl_Interp *interp, enum traceOptionsEnum optionIndex, +} TraceOptions; +typedef int (Tcl_TraceTypeObjCmd)(Tcl_Interp *interp, TraceOptions optionIndex, Tcl_Size objc, Tcl_Obj *const objv[]); static Tcl_TraceTypeObjCmd TraceVariableObjCmd; @@ -146,7 +147,7 @@ static int TraceVarEx(Tcl_Interp *interp, const char *part1, */ typedef struct { - void *clientData; /* Client data from Tcl_CreateTrace */ + void *clientData; /* Client data from Tcl_CreateTrace */ Tcl_CmdTraceProc *proc; /* Trace function from Tcl_CreateTrace */ } StringTraceData; @@ -196,7 +197,7 @@ Tcl_TraceObjCmd( "add", "info", "remove", NULL }; - enum traceOptionsEnum optionIndex; + TraceOptions optionIndex; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); @@ -279,8 +280,8 @@ Tcl_TraceObjCmd( static int TraceExecutionObjCmd( Tcl_Interp *interp, /* Current interpreter. */ - enum traceOptionsEnum optionIndex, /* Add, info or remove */ - Tcl_Size objc, /* Number of arguments. */ + TraceOptions optionIndex, /* Add, info or remove */ + Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { const char *name, *command; @@ -530,8 +531,8 @@ TraceExecutionObjCmd( static int TraceCommandObjCmd( Tcl_Interp *interp, /* Current interpreter. */ - enum traceOptionsEnum optionIndex, /* Add, info or remove */ - Tcl_Size objc, /* Number of arguments. */ + TraceOptions optionIndex, /* Add, info or remove */ + Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { const char *name, *command; @@ -728,8 +729,8 @@ TraceCommandObjCmd( static int TraceVariableObjCmd( Tcl_Interp *interp, /* Current interpreter. */ - enum traceOptionsEnum optionIndex, /* Add, info or remove */ - Tcl_Size objc, /* Number of arguments. */ + TraceOptions optionIndex, /* Add, info or remove */ + Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { const char *name, *command; @@ -993,7 +994,7 @@ Tcl_TraceCommand( * of the TRACE_*_EXEC flags */ Tcl_CommandTraceProc *proc, /* Function to call when specified ops are * invoked upon cmdName. */ - void *clientData) /* Arbitrary argument to pass to proc. */ + void *clientData) /* Arbitrary argument to pass to proc. */ { Command *cmdPtr; CommandTrace *tracePtr; @@ -1056,7 +1057,7 @@ Tcl_UntraceCommand( * TCL_TRACE_RENAME, TCL_TRACE_DELETE, and any * of the TRACE_*_EXEC flags */ Tcl_CommandTraceProc *proc, /* Function assocated with trace. */ - void *clientData) /* Arbitrary argument to pass to proc. */ + void *clientData) /* Arbitrary argument to pass to proc. */ { CommandTrace *tracePtr; CommandTrace *prevPtr; @@ -1161,7 +1162,7 @@ Tcl_UntraceCommand( static void TraceCommandProc( - void *clientData, /* Information about the command trace. */ + void *clientData, /* Information about the command trace. */ Tcl_Interp *interp, /* Interpreter containing command. */ const char *oldName, /* Name of command being changed. */ const char *newName, /* New name of command. Empty string or NULL @@ -1306,7 +1307,7 @@ TclCheckExecutionTraces( Command *cmdPtr, /* Points to command's Command struct. */ int code, /* The current result code. */ int traceFlags, /* Current tracing situation. */ - Tcl_Size objc, /* Number of arguments for the command. */ + Tcl_Size objc, /* Number of arguments for the command. */ Tcl_Obj *const objv[]) /* Pointers to Tcl_Obj of each argument. */ { Interp *iPtr = (Interp *) interp; @@ -1412,7 +1413,7 @@ TclCheckInterpTraces( Command *cmdPtr, /* Points to command's Command struct. */ int code, /* The current result code. */ int traceFlags, /* Current tracing situation. */ - Tcl_Size objc, /* Number of arguments for the command. */ + Tcl_Size objc, /* Number of arguments for the command. */ Tcl_Obj *const objv[]) /* Pointers to Tcl_Obj of each argument. */ { Interp *iPtr = (Interp *) interp; @@ -1550,7 +1551,7 @@ TclCheckInterpTraces( static int CallTraceFunction( Tcl_Interp *interp, /* The current interpreter. */ - Trace *tracePtr, /* Describes the trace function to call. */ + Trace *tracePtr, /* Describes the trace function to call. */ Command *cmdPtr, /* Points to command's Command struct. */ const char *command, /* Points to the first character of the * command's source before substitutions. */ @@ -1799,15 +1800,15 @@ TraceExecutionProc( if ((flags & TCL_TRACE_ENTER_EXEC) && (tcmdPtr->stepTrace == NULL) && (tcmdPtr->flags & (TCL_TRACE_ENTER_DURING_EXEC | TCL_TRACE_LEAVE_DURING_EXEC))) { - unsigned len = strlen(command) + 1; + size_t len = strlen(command) + 1; tcmdPtr->startLevel = level; tcmdPtr->startCmd = (char *)Tcl_Alloc(len); memcpy(tcmdPtr->startCmd, command, len); tcmdPtr->refCount++; tcmdPtr->stepTrace = Tcl_CreateObjTrace2(interp, 0, - (tcmdPtr->flags & TCL_TRACE_ANY_EXEC) >> 2, - TraceExecutionProc, tcmdPtr, CommandObjTraceDeleted); + (tcmdPtr->flags & TCL_TRACE_ANY_EXEC) >> 2, + TraceExecutionProc, tcmdPtr, CommandObjTraceDeleted); } } if (flags & TCL_TRACE_DESTROYED) { @@ -1845,7 +1846,7 @@ TraceExecutionProc( static char * TraceVarProc( - void *clientData, /* Information about the variable trace. */ + void *clientData, /* Information about the variable trace. */ Tcl_Interp *interp, /* Interpreter containing variable. */ const char *name1, /* Name of variable or array. */ const char *name2, /* Name of element within array; NULL means @@ -1997,7 +1998,7 @@ typedef struct { } TraceWrapperInfo; static int -traceWrapperProc( +TraceWrapperProc( void *clientData, Tcl_Interp *interp, Tcl_Size level, @@ -2007,14 +2008,15 @@ traceWrapperProc( Tcl_Obj *const objv[]) { TraceWrapperInfo *info = (TraceWrapperInfo *)clientData; - if (objc > INT_MAX) { + if (objc > INT_MAX || objc < 0) { objc = -1; /* Signal Tcl_CmdObjTraceProc that objc is out of range */ } - return info->proc(info->clientData, interp, (int)level, command, commandInfo, objc, objv); + return info->proc(info->clientData, interp, (int)level, command, commandInfo, + (int)objc, objv); } static void -traceWrapperDelProc( +TraceWrapperDelProc( void *clientData) { TraceWrapperInfo *info = (TraceWrapperInfo *)clientData; @@ -2028,10 +2030,10 @@ traceWrapperDelProc( Tcl_Trace Tcl_CreateObjTrace( Tcl_Interp *interp, /* Tcl interpreter */ - Tcl_Size level, /* Maximum nesting level */ + Tcl_Size level, /* Maximum nesting level */ int flags, /* Flags, see above */ Tcl_CmdObjTraceProc *proc, /* Trace callback */ - void *clientData, /* Client data for the callback */ + void *clientData, /* Client data for the callback */ Tcl_CmdObjTraceDeleteProc *delProc) /* Function to call when trace is deleted */ { @@ -2040,17 +2042,17 @@ Tcl_CreateObjTrace( info->delProc = delProc; info->clientData = clientData; return Tcl_CreateObjTrace2(interp, level, flags, - (proc ? traceWrapperProc : NULL), - info, traceWrapperDelProc); + (proc ? TraceWrapperProc : NULL), + info, TraceWrapperDelProc); } Tcl_Trace Tcl_CreateObjTrace2( Tcl_Interp *interp, /* Tcl interpreter */ - Tcl_Size level, /* Maximum nesting level */ + Tcl_Size level, /* Maximum nesting level */ int flags, /* Flags, see above */ Tcl_CmdObjTraceProc2 *proc, /* Trace callback */ - void *clientData, /* Client data for the callback */ + void *clientData, /* Client data for the callback */ Tcl_CmdObjTraceDeleteProc *delProc) /* Function to call when trace is deleted */ { @@ -2136,11 +2138,11 @@ Tcl_CreateObjTrace2( Tcl_Trace Tcl_CreateTrace( Tcl_Interp *interp, /* Interpreter in which to create trace. */ - Tcl_Size level, /* Only call proc for commands at nesting + Tcl_Size level, /* Only call proc for commands at nesting * level<=argument level (1=>top level). */ Tcl_CmdTraceProc *proc, /* Function to call before executing each * command. */ - void *clientData) /* Arbitrary value word to pass to proc. */ + void *clientData) /* Arbitrary value word to pass to proc. */ { StringTraceData *data = (StringTraceData *)Tcl_Alloc(sizeof(StringTraceData)); @@ -2199,8 +2201,8 @@ StringTraceProc( * either command or argv. */ - data->proc(data->clientData, interp, level, (char *) command, - cmdPtr->proc, cmdPtr->clientData, objc, argv); + data->proc(data->clientData, interp, (int)level, (char *) command, + cmdPtr->proc, cmdPtr->clientData, (int)objc, argv); TclStackFree(interp, (void *) argv); return TCL_OK; @@ -2405,7 +2407,7 @@ TclCheckArrayTraces( Var *varPtr, Var *arrayPtr, Tcl_Obj *name, - int index) + Tcl_Size index) { int code = TCL_OK; @@ -2458,7 +2460,7 @@ TclObjCallVarTraces( int leaveErrMsg, /* If true, and one of the traces indicates an * error, then leave an error message and * stack trace information in *iPTr. */ - int index) /* Index into the local variable table of the + Tcl_Size index) /* Index into the local variable table of the * variable, or -1. Only used when part1Ptr is * NULL. */ { @@ -2540,7 +2542,7 @@ TclCallVarTraces( } while (*p != '\0'); p--; if (*p == ')') { - int offset = (openParen - part1); + Tcl_Size offset = (openParen - part1); char *newPart1; Tcl_DStringInit(&nameCopy); @@ -2788,7 +2790,7 @@ Tcl_UntraceVar2( * TCL_TRACE_WRITES, TCL_TRACE_UNSETS, * TCL_GLOBAL_ONLY, and TCL_NAMESPACE_ONLY. */ Tcl_VarTraceProc *proc, /* Function associated with trace. */ - void *clientData) /* Arbitrary argument to pass to proc. */ + void *clientData) /* Arbitrary argument to pass to proc. */ { VarTrace *tracePtr; VarTrace *prevPtr, *nextPtr; @@ -2816,7 +2818,7 @@ Tcl_UntraceVar2( */ flagMask = TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | - TCL_TRACE_ARRAY | TCL_TRACE_RESULT_DYNAMIC | TCL_TRACE_RESULT_OBJECT; + TCL_TRACE_ARRAY | TCL_TRACE_RESULT_DYNAMIC | TCL_TRACE_RESULT_OBJECT; flags &= flagMask; hPtr = Tcl_FindHashEntry(&iPtr->varTraces, varPtr); @@ -2991,7 +2993,7 @@ Tcl_TraceVar2( * TCL_NAMESPACE_ONLY. */ Tcl_VarTraceProc *proc, /* Function to call when specified ops are * invoked upon varName. */ - void *clientData) /* Arbitrary argument to pass to proc. */ + void *clientData) /* Arbitrary argument to pass to proc. */ { VarTrace *tracePtr; int result; @@ -3080,7 +3082,7 @@ TraceVarEx( */ flagMask = TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | - TCL_TRACE_ARRAY | TCL_TRACE_RESULT_DYNAMIC | TCL_TRACE_RESULT_OBJECT; + TCL_TRACE_ARRAY | TCL_TRACE_RESULT_DYNAMIC | TCL_TRACE_RESULT_OBJECT; tracePtr->flags = tracePtr->flags & flagMask; hPtr = Tcl_CreateHashEntry(&iPtr->varTraces, varPtr, &isNew); diff --git a/generic/tclUniData.c b/generic/tclUniData.c index c2b11cb..6c4af08 100644 --- a/generic/tclUniData.c +++ b/generic/tclUniData.c @@ -1734,9 +1734,9 @@ static const int groups[] = { }; #if TCL_UTF_MAX > 3 || TCL_MAJOR_VERSION > 8 -# define UNICODE_OUT_OF_RANGE(ch) (((ch) & 0x1FFFFF) >= 0x323C0) +# define UNICODE_OUT_OF_RANGE(ch) (((ch) & 0x1FFFFF) >= 0x323C0) #else -# define UNICODE_OUT_OF_RANGE(ch) (((ch) & 0x1F0000) != 0) +# define UNICODE_OUT_OF_RANGE(ch) (((ch) & 0x1F0000) != 0) #endif /* @@ -1783,9 +1783,9 @@ enum { * to do sign extension on right shifts. */ -#define GetCaseType(info) (((info) & 0xE0) >> 5) -#define GetCategory(ch) (GetUniCharInfo(ch) & 0x1F) -#define GetDelta(info) ((info) >> 8) +#define GetCaseType(info) (((info) & 0xE0) >> 5) +#define GetCategory(ch) (GetUniCharInfo(ch) & 0x1F) +#define GetDelta(info) ((info) >> 8) /* * This macro extracts the information about a character from the @@ -1793,7 +1793,9 @@ enum { */ #if TCL_UTF_MAX > 3 || TCL_MAJOR_VERSION > 8 -# define GetUniCharInfo(ch) (groups[groupMap[pageMap[((ch) & 0x1FFFFF) >> OFFSET_BITS] | ((ch) & ((1 << OFFSET_BITS)-1))]]) +# define GetUniCharInfo(ch) \ + (groups[groupMap[pageMap[((ch) & 0x1FFFFF) >> OFFSET_BITS] | ((ch) & ((1 << OFFSET_BITS)-1))]]) #else -# define GetUniCharInfo(ch) (groups[groupMap[pageMap[((ch) & 0xFFFF) >> OFFSET_BITS] | ((ch) & ((1 << OFFSET_BITS)-1))]]) +# define GetUniCharInfo(ch) \ + (groups[groupMap[pageMap[((ch) & 0xFFFF) >> OFFSET_BITS] | ((ch) & ((1 << OFFSET_BITS)-1))]]) #endif diff --git a/generic/tclUtf.c b/generic/tclUtf.c index 2406ac2..e12b675 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -552,7 +552,7 @@ Tcl_UtfToChar16( && ((src[1] & 0xC0) == 0x80) && ((src[2] & 0xC0) == 0x80) && (((((byte - 0x10) << 2) & 0xFC) | 0xD800) == (*chPtr & 0xFCFC)) && ((src[1] & 0xF0) == (((*chPtr << 4) & 0x30) | 0x80))) { - *chPtr = ((src[1] & 0x0F) << 6) + (src[2] & 0x3F) + 0xDC00; + *chPtr = (unsigned short)(((src[1] & 0x0F) << 6) + (src[2] & 0x3F) + 0xDC00); return 3; } if ((unsigned)(byte-0x80) < (unsigned)0x20) { @@ -604,7 +604,7 @@ Tcl_UtfToChar16( | ((src[2] & 0x3F) >> 4)) - 0x40; if (high < 0x400) { /* produce high surrogate, advance source pointer */ - *chPtr = 0xD800 + high; + *chPtr = (unsigned short)(0xD800 + high); return 1; } /* out of range, < 0x10000 or > 0x10FFFF */ @@ -801,9 +801,9 @@ Tcl_UtfCharComplete( Tcl_Size Tcl_NumUtfChars( - const char *src, /* The UTF-8 string to measure. */ - Tcl_Size length) /* The length of the string in bytes, or - * negative value for strlen(src). */ + const char *src, /* The UTF-8 string to measure. */ + Tcl_Size length) /* The length of the string in bytes, or + * negative value for strlen(src). */ { Tcl_UniChar ch = 0; Tcl_Size i = 0; @@ -853,9 +853,9 @@ Tcl_NumUtfChars( Tcl_Size TclNumUtfChars( - const char *src, /* The UTF-8 string to measure. */ - Tcl_Size length) /* The length of the string in bytes, or - * negative for strlen(src). */ + const char *src, /* The UTF-8 string to measure. */ + Tcl_Size length) /* The length of the string in bytes, or + * negative for strlen(src). */ { unsigned short ch = 0; Tcl_Size i = 0; @@ -1177,8 +1177,8 @@ Tcl_UtfPrev( int Tcl_UniCharAtIndex( - const char *src, /* The UTF-8 string to dereference. */ - Tcl_Size index) /* The position of the desired character. */ + const char *src, /* The UTF-8 string to dereference. */ + Tcl_Size index) /* The position of the desired character. */ { Tcl_UniChar ch = 0; int i = 0; @@ -1213,8 +1213,8 @@ Tcl_UniCharAtIndex( const char * Tcl_UtfAtIndex( - const char *src, /* The UTF-8 string. */ - Tcl_Size index) /* The position of the desired character. */ + const char *src, /* The UTF-8 string. */ + Tcl_Size index) /* The position of the desired character. */ { Tcl_UniChar ch = 0; @@ -1226,8 +1226,8 @@ Tcl_UtfAtIndex( const char * TclUtfAtIndex( - const char *src, /* The UTF-8 string. */ - Tcl_Size index) /* The position of the desired character. */ + const char *src, /* The UTF-8 string. */ + Tcl_Size index) /* The position of the desired character. */ { unsigned short ch = 0; Tcl_Size len = 0; @@ -1646,8 +1646,8 @@ TclUtfNcasecmp( } else if ((ch2 & 0xFC00) == 0xD800) { return -ch2; } - ch1 = Tcl_UniCharToLower(ch1); - ch2 = Tcl_UniCharToLower(ch2); + ch1 = (unsigned short)Tcl_UniCharToLower(ch1); + ch2 = (unsigned short)Tcl_UniCharToLower(ch2); if (ch1 != ch2) { return (ch1 - ch2); } diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 950cae6..9dc88c4 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -4151,7 +4151,6 @@ TclSetProcessGlobalValue( const char *bytes; Tcl_HashTable *cacheMap; Tcl_HashEntry *hPtr; - int dummy; Tcl_DString ds; Tcl_MutexLock(&pgvPtr->mutex); @@ -4188,7 +4187,7 @@ TclSetProcessGlobalValue( Tcl_IncrRefCount(newValue); cacheMap = GetThreadHash(&pgvPtr->key); ClearHash(cacheMap); - hPtr = Tcl_CreateHashEntry(cacheMap, INT2PTR(pgvPtr->epoch), &dummy); + hPtr = Tcl_CreateHashEntry(cacheMap, INT2PTR(pgvPtr->epoch), NULL); Tcl_SetHashValue(hPtr, newValue); Tcl_MutexUnlock(&pgvPtr->mutex); } @@ -4252,7 +4251,6 @@ TclGetProcessGlobalValue( cacheMap = GetThreadHash(&pgvPtr->key); hPtr = Tcl_FindHashEntry(cacheMap, INT2PTR(epoch)); if (NULL == hPtr) { - int dummy; /* * No cache for the current epoch - must be a new one. @@ -4285,7 +4283,7 @@ TclGetProcessGlobalValue( Tcl_ExternalToUtfDString(NULL, pgvPtr->value, pgvPtr->numBytes, &newValue); value = Tcl_DStringToObj(&newValue); hPtr = Tcl_CreateHashEntry(cacheMap, - INT2PTR(pgvPtr->epoch), &dummy); + INT2PTR(pgvPtr->epoch), NULL); Tcl_MutexUnlock(&pgvPtr->mutex); Tcl_SetHashValue(hPtr, value); Tcl_IncrRefCount(value); diff --git a/generic/tclVar.c b/generic/tclVar.c index 53538df..c41e12c 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -60,7 +60,7 @@ VarHashCreateVar( Tcl_Obj *key, int *newPtr) { - Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(&tablePtr->table, key, newPtr); + Tcl_HashEntry *hPtr = Tcl_AttemptCreateHashEntry(&tablePtr->table, key, newPtr); if (!hPtr) { return NULL; @@ -68,8 +68,18 @@ VarHashCreateVar( return VarHashGetValue(hPtr); } -#define VarHashFindVar(tablePtr, key) \ - VarHashCreateVar((tablePtr), (key), NULL) +static inline Var * +VarHashFindVar( + TclVarHashTable *tablePtr, + Tcl_Obj *key) +{ + Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&tablePtr->table, key); + + if (!hPtr) { + return NULL; + } + return VarHashGetValue(hPtr); +} #define VarHashInvalidateEntry(varPtr) \ ((varPtr)->flags |= VAR_DEAD_HASH) @@ -117,6 +127,7 @@ VarHashNextVar( */ static const char NOSUCHVAR[] = "no such variable"; +static const char MEMERROR[] = "memory error"; static const char ISARRAY[] = "variable is array"; static const char NEEDARRAY[] = "variable isn't array"; static const char NOSUCHELEMENT[] = "no such element in array"; @@ -191,7 +202,7 @@ static Tcl_NRPostProc ArrayForLoopCallback; static Tcl_ObjCmdProc ArrayForNRCmd; static void DeleteSearches(Interp *iPtr, Var *arrayVarPtr); static void DeleteArray(Interp *iPtr, Tcl_Obj *arrayNamePtr, - Var *varPtr, int flags, int index); + Var *varPtr, int flags, Tcl_Size index); static int LocateArray(Tcl_Interp *interp, Tcl_Obj *name, Var **varPtrPtr, int *isArrayPtr); static int NotArrayError(Tcl_Interp *interp, Tcl_Obj *name); @@ -201,12 +212,12 @@ static Tcl_Var ObjFindNamespaceVar(Tcl_Interp *interp, static int ObjMakeUpvar(Tcl_Interp *interp, CallFrame *framePtr, Tcl_Obj *otherP1Ptr, const char *otherP2, int otherFlags, - Tcl_Obj *myNamePtr, int myFlags, int index); + Tcl_Obj *myNamePtr, int myFlags, Tcl_Size index); static ArraySearch * ParseSearchId(Tcl_Interp *interp, const Var *varPtr, Tcl_Obj *varNamePtr, Tcl_Obj *handleObj); static void UnsetVarStruct(Var *varPtr, Var *arrayPtr, Interp *iPtr, Tcl_Obj *part1Ptr, - Tcl_Obj *part2Ptr, int flags, int index); + Tcl_Obj *part2Ptr, int flags, Tcl_Size index); /* * TIP #508: [array default] @@ -223,7 +234,7 @@ static void SetArrayDefault(Var *arrayPtr, Tcl_Obj *defaultObj); MODULE_SCOPE Var * TclLookupSimpleVar(Tcl_Interp *interp, Tcl_Obj *varNamePtr, int flags, int create, - const char **errMsgPtr, int *indexPtr); + const char **errMsgPtr, Tcl_Size *indexPtr); static Tcl_DupInternalRepProc DupLocalVarName; static Tcl_FreeInternalRepProc FreeLocalVarName; @@ -344,8 +355,8 @@ NotArrayError( { const char *nameStr = TclGetString(name); - Tcl_SetObjResult(interp, - Tcl_ObjPrintf("\"%s\" isn't an array", nameStr)); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" isn't an array", nameStr)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", nameStr, (char *)NULL); return TCL_ERROR; } @@ -607,7 +618,8 @@ TclObjLookupVarEx( Var *varPtr; /* Points to the variable's in-frame Var * structure. */ const char *errMsg = NULL; - int index, parsed = 0; + Tcl_Size index; + int parsed = 0; Tcl_Size localIndex; Tcl_Obj *namePtr, *arrayPtr, *elem; @@ -831,7 +843,7 @@ TclLookupSimpleVar( * if it doesn't already exist. If 0, return * error if it doesn't exist. */ const char **errMsgPtr, - int *indexPtr) + Tcl_Size *indexPtr) { Interp *iPtr = (Interp *) interp; CallFrame *varFramePtr = iPtr->varFramePtr; @@ -846,7 +858,7 @@ TclLookupSimpleVar( * the variable. */ Namespace *varNsPtr, *cxtNsPtr, *dummy1Ptr, *dummy2Ptr; ResolverScheme *resPtr; - int isNew, result; + int result; Tcl_Size i, varLen; const char *varName = TclGetStringFromObj(varNamePtr, &varLen); @@ -958,7 +970,11 @@ TclLookupSimpleVar( } else { tailPtr = varNamePtr; } - varPtr = VarHashCreateVar(&varNsPtr->varTable, tailPtr, &isNew); + varPtr = VarHashCreateVar(&varNsPtr->varTable, tailPtr, NULL); + if (varPtr == NULL) { + *errMsgPtr = MEMERROR; + return NULL; + } if (lookGlobal) { /* * The variable was created starting from the global @@ -1001,7 +1017,10 @@ TclLookupSimpleVar( tablePtr->arrayPtr = varPtr; varFramePtr->varTablePtr = tablePtr; } - varPtr = VarHashCreateVar(tablePtr, varNamePtr, &isNew); + varPtr = VarHashCreateVar(tablePtr, varNamePtr, NULL); + if (varPtr == NULL) { + *errMsgPtr = MEMERROR; + } } else { varPtr = NULL; if (tablePtr != NULL) { @@ -1072,7 +1091,7 @@ TclLookupArrayElement( * element, if it doesn't already exist. If 0, * return error if it doesn't exist. */ Var *arrayPtr, /* Pointer to the array's Var structure. */ - int index) /* If >=0, the index of the local array. */ + Tcl_Size index) /* If >=0, the index of the local array. */ { int isNew; Var *varPtr; @@ -1122,7 +1141,14 @@ TclLookupArrayElement( if (createElem) { varPtr = VarHashCreateVar(arrayPtr->value.tablePtr, elNamePtr, &isNew); - if (isNew) { + if (varPtr == NULL) { + if (flags & TCL_LEAVE_ERR_MSG) { + TclObjVarErrMsg(interp, arrayNamePtr, elNamePtr, msg, + NOSUCHELEMENT, index); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ELEMENT", + TclGetString(elNamePtr), (char *)NULL); + } + } else if (isNew) { if (arrayPtr->flags & VAR_SEARCH_ACTIVE) { DeleteSearches((Interp *) interp, arrayPtr); } @@ -1384,7 +1410,7 @@ TclPtrGetVarIdx( * in the array part1. */ int flags, /* OR-ed combination of TCL_GLOBAL_ONLY, and * TCL_LEAVE_ERR_MSG bits. */ - int index) /* Index into the local variable table of the + Tcl_Size index) /* Index into the local variable table of the * variable, or -1. Only used when part1Ptr is * NULL. */ { @@ -1912,7 +1938,7 @@ TclPtrSetVarIdx( Tcl_Obj *newValuePtr, /* New value for variable. */ int flags, /* OR-ed combination of TCL_GLOBAL_ONLY, and * TCL_LEAVE_ERR_MSG bits. */ - int index) /* Index of local var where part1 is to be + Tcl_Size index) /* Index of local var where part1 is to be * found. */ { Interp *iPtr = (Interp *) interp; @@ -2229,7 +2255,7 @@ TclPtrIncrObjVarIdx( * any of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, * TCL_APPEND_VALUE, TCL_LIST_ELEMENT, * TCL_LEAVE_ERR_MSG. */ - int index) /* Index into the local variable table of the + Tcl_Size index) /* Index into the local variable table of the * variable, or -1. Only used when part1Ptr is * NULL. */ { @@ -2464,7 +2490,7 @@ TclPtrUnsetVarIdx( int flags, /* OR-ed combination of any of * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, * TCL_LEAVE_ERR_MSG. */ - int index) /* Index into the local variable table of the + Tcl_Size index) /* Index into the local variable table of the * variable, or -1. Only used when part1Ptr is * NULL. */ { @@ -2505,7 +2531,8 @@ TclPtrUnsetVarIdx( if (result != TCL_OK) { if (flags & TCL_LEAVE_ERR_MSG) { TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "unset", - ((initialArrayPtr == NULL) ? NOSUCHVAR : NOSUCHELEMENT), index); + ((initialArrayPtr == NULL) ? NOSUCHVAR : NOSUCHELEMENT), + index); Tcl_SetErrorCode(interp, "TCL", "UNSET", "VARNAME", (char *)NULL); } } @@ -2550,7 +2577,7 @@ UnsetVarStruct( Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags, - int index) + Tcl_Size index) { Var dummyVar; int traced = TclIsVarTraced(varPtr) @@ -2598,15 +2625,13 @@ UnsetVarStruct( * Otherwise just delete them. */ - int isNew; - tPtr = Tcl_FindHashEntry(&iPtr->varTraces, varPtr); tracePtr = (VarTrace *)Tcl_GetHashValue(tPtr); varPtr->flags &= ~VAR_ALL_TRACES; Tcl_DeleteHashEntry(tPtr); if (dummyVar.flags & VAR_TRACED_UNSET) { tPtr = Tcl_CreateHashEntry(&iPtr->varTraces, - &dummyVar, &isNew); + &dummyVar, NULL); Tcl_SetHashValue(tPtr, tracePtr); } } @@ -2629,7 +2654,7 @@ UnsetVarStruct( dummyVar.flags &= ~VAR_TRACE_ACTIVE; TclObjCallVarTraces(iPtr, arrayPtr, &dummyVar, part1Ptr, part2Ptr, - (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|VAR_ARRAY_ELEMENT)) + (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|VAR_ARRAY_ELEMENT)) | TCL_TRACE_UNSETS, /* leaveErrMsg */ 0, index); @@ -2735,7 +2760,8 @@ Tcl_UnsetObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int i, flags = TCL_LEAVE_ERR_MSG; + int i; + int flags = TCL_LEAVE_ERR_MSG; const char *name; if (objc == 1) { @@ -3967,13 +3993,12 @@ TclFindArrayPtrElements( varPtr!=NULL ; varPtr=VarHashNextVar(&search)) { Tcl_HashEntry *hPtr; Tcl_Obj *nameObj; - int dummy; if (TclIsVarUndefined(varPtr)) { continue; } nameObj = VarHashGetKey(varPtr); - hPtr = Tcl_CreateHashEntry(tablePtr, nameObj, &dummy); + hPtr = Tcl_CreateHashEntry(tablePtr, nameObj, NULL); Tcl_SetHashValue(hPtr, nameObj); } } @@ -4488,7 +4513,7 @@ ObjMakeUpvar( * otherP1/otherP2. Must be a scalar. */ int myFlags, /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY: * indicates scope of myName. */ - int index) /* If the variable to be linked is an indexed + Tcl_Size index) /* If the variable to be linked is an indexed * scalar, this is its index. Otherwise, -1 */ { Interp *iPtr = (Interp *) interp; @@ -4618,7 +4643,7 @@ TclPtrObjMakeUpvarIdx( * otherP1/otherP2. Must be a scalar. */ int myFlags, /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY: * indicates scope of myName. */ - int index) /* If the variable to be linked is an indexed + Tcl_Size index) /* If the variable to be linked is an indexed * scalar, this is its index. Otherwise, -1 */ { Interp *iPtr = (Interp *) interp; @@ -4946,7 +4971,8 @@ Tcl_GlobalObjCmd( Tcl_Obj *objPtr, *tailPtr; const char *varName; const char *tail; - int result, i; + int result; + int i; /* * If we are not executing inside a Tcl procedure, just return. @@ -5050,7 +5076,8 @@ Tcl_VariableObjCmd( const char *varName, *tail, *cp; Var *varPtr, *arrayPtr; Tcl_Obj *varValuePtr; - int i, result; + int i; + int result; Tcl_Obj *varNamePtr, *tailPtr; for (i=1 ; i<objc ; i+=2) { @@ -5579,7 +5606,7 @@ DeleteArray( int flags, /* Flags to pass to TclCallVarTraces: * TCL_TRACE_UNSETS and sometimes * TCL_NAMESPACE_ONLY or TCL_GLOBAL_ONLY. */ - int index) + Tcl_Size index) { Tcl_HashSearch search; Tcl_HashEntry *tPtr; @@ -5696,7 +5723,7 @@ TclObjVarErrMsg( const char *operation, /* String describing operation that failed, * e.g. "read", "set", or "unset". */ const char *reason, /* String describing why operation failed. */ - int index) /* Index into the local variable table of the + Tcl_Size index) /* Index into the local variable table of the * variable, or -1. Only used when part1Ptr is * NULL. */ { @@ -6735,7 +6762,10 @@ AllocVarEntry( Tcl_HashEntry *hPtr; Var *varPtr; - varPtr = (Var *)Tcl_Alloc(sizeof(VarInHash)); + varPtr = (Var *)Tcl_AttemptAlloc(sizeof(VarInHash)); + if (!varPtr) { + return NULL; + } varPtr->flags = VAR_IN_HASHTABLE; varPtr->value.objPtr = NULL; VarHashRefCount(varPtr) = 1; diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index cd17306..df9b99e 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -967,51 +967,25 @@ DecodeZipEntryText( Tcl_DString *dstPtr) /* Must have been initialized by caller! */ { Tcl_Encoding encoding; - const char *src; - char *dst; - int dstLen, srcLen = inputLength, flags; - Tcl_EncodingState state; if (inputLength < 1) { return Tcl_DStringValue(dstPtr); } /* - * We can't use Tcl_ExternalToUtfDString at this point; it has no way to - * fail. So we use this modified version of it that can report encoding - * errors to us (so we can fall back to something else). + * We Tcl_ExternalToUtfDStringEx because that can report if it failed, + * allowing us to try a different encoding. * - * The utf-8 encoding is implemented internally, and so is guaranteed to - * be present. + * The UTF-8 encoding is implemented internally, and so is guaranteed to + * be present. Tcl's own startup files (including the encoding definitions) + * should all have ASCII filenames, which is a subset of UTF-8, and so they + * should all work via this. */ - src = (const char *) inputBytes; - dst = Tcl_DStringValue(dstPtr); - dstLen = dstPtr->spaceAvl - 1; - flags = TCL_ENCODING_START | TCL_ENCODING_END; /* Special flag! */ - - while (1) { - int srcRead, dstWrote; - int result = Tcl_ExternalToUtf(NULL, tclUtf8Encoding, src, srcLen, flags, - &state, dst, dstLen, &srcRead, &dstWrote, NULL); - int soFar = dst + dstWrote - Tcl_DStringValue(dstPtr); - - if (result == TCL_OK) { - Tcl_DStringSetLength(dstPtr, soFar); - return Tcl_DStringValue(dstPtr); - } else if (result != TCL_CONVERT_NOSPACE) { - break; - } - - flags &= ~TCL_ENCODING_START; - src += srcRead; - srcLen -= srcRead; - if (Tcl_DStringLength(dstPtr) == 0) { - Tcl_DStringSetLength(dstPtr, dstLen); - } - Tcl_DStringSetLength(dstPtr, 2 * Tcl_DStringLength(dstPtr) + 1); - dst = Tcl_DStringValue(dstPtr) + soFar; - dstLen = Tcl_DStringLength(dstPtr) - soFar - 1; + if (Tcl_ExternalToUtfDStringEx(NULL, tclUtf8Encoding, + (const char *) inputBytes, inputLength, + TCL_ENCODING_PROFILE_STRICT, dstPtr, NULL) == TCL_OK) { + return Tcl_DStringValue(dstPtr); } /* @@ -3890,8 +3864,7 @@ SerializeCentralDirectorySuffix( const unsigned char *end, /* The end of writable memory. */ unsigned char *buf, /* Where to serialize to */ int entryCount, /* The number of entries in the directory */ - long long dataStartOffset, - /* The overall file offset of the start of the + long long dataStartOffset, /* The overall file offset of the start of the * data file. */ long long directoryStartOffset, /* The overall file offset of the start of the @@ -5641,7 +5614,7 @@ ZipFSMatchInDirectoryProc( Tcl_DString dsPref, *prefixBuf = NULL; int foundInHash, notDuplicate; ZipEntry *z; - int wanted; /* TCL_GLOB_TYPE* */ + int wanted; /* TCL_GLOB_TYPE* */ if (!normPathPtr) { return -1; diff --git a/library/dde/pkgIndex.tcl b/library/dde/pkgIndex.tcl index 542f5e5..aea9a1c 100644 --- a/library/dde/pkgIndex.tcl +++ b/library/dde/pkgIndex.tcl @@ -1,11 +1,5 @@ +if {![package vsatisfies [package provide Tcl] 9.0-]} return if {[info sharedlibextension] != ".dll"} return -if {[package vsatisfies [package provide Tcl] 9.0-]} { - package ifneeded dde 1.4.5 \ - [list load [file join $dir tcl9dde14.dll] Dde] -} elseif {[::tcl::pkgconfig get debug]} { - package ifneeded dde 1.4.5 \ - [list load [file join $dir tcldde14g.dll] Dde] -} else { - package ifneeded dde 1.4.5 \ - [list load [file join $dir tcldde14.dll] Dde] -} +package ifneeded dde 1.5a1 \ + [list load [file join $dir tcl9dde15.dll] Dde] + diff --git a/library/http/http.tcl b/library/http/http.tcl index b429623..6050ed9 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -2461,7 +2461,7 @@ proc http::Connected {token proto phost srvurl} { # be discarded. } elseif {$state(status) eq ""} { # https handshake errors come here, for - # Tcl 9.0 without http::SecureProxyConnect, and for Tcl 8.6. + # Tcl 8.7 without http::SecureProxyConnect, and for Tcl 8.6. set msg [registerError $sock] registerError $sock {} if {$msg eq {}} { @@ -3622,7 +3622,7 @@ proc http::Event {sock token} { # they will be discarded. } else { # https handshake errors come here, for - # Tcl 9.0 with http::SecureProxyConnect. + # Tcl 8.7 with http::SecureProxyConnect. set msg [registerError $sock] registerError $sock {} if {$msg eq {}} { diff --git a/library/init.tcl b/library/init.tcl index 50e8f14..5231b85 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -15,7 +15,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -package require -exact tcl 9.0.3 +package require -exact tcl 9.1a1 # Compute the auto path to use in this interpreter. # The values on the path come from several locations: diff --git a/library/msgcat/msgcat.tcl b/library/msgcat/msgcat.tcl index 7d85ad8..decf1d2 100644 --- a/library/msgcat/msgcat.tcl +++ b/library/msgcat/msgcat.tcl @@ -11,8 +11,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# We use oo::define::self, which is new in Tcl 9.0 -package require Tcl 9.0- +# We use oo::define::self, which is new in Tcl 8.7 +package require Tcl 8.7- # When the version number changes, be sure to update the pkgIndex.tcl file, # and the installation directory in the Makefiles. package provide msgcat 1.7.1 diff --git a/library/msgcat/pkgIndex.tcl b/library/msgcat/pkgIndex.tcl index 79d360a..e141c67 100644 --- a/library/msgcat/pkgIndex.tcl +++ b/library/msgcat/pkgIndex.tcl @@ -1,2 +1,2 @@ -if {![package vsatisfies [package provide Tcl] 9.0-]} {return} +if {![package vsatisfies [package provide Tcl] 8.7-]} {return} package ifneeded msgcat 1.7.1 [list source -encoding utf-8 [file join $dir msgcat.tcl]] diff --git a/library/registry/pkgIndex.tcl b/library/registry/pkgIndex.tcl index edb4729..f543d35 100644 --- a/library/registry/pkgIndex.tcl +++ b/library/registry/pkgIndex.tcl @@ -1,9 +1,4 @@ -if {![package vsatisfies [package provide Tcl] 8.5-]} return +if {![package vsatisfies [package provide Tcl] 9.0-]} return if {[info sharedlibextension] != ".dll"} return -if {[package vsatisfies [package provide Tcl] 9.0-]} { - package ifneeded registry 1.3.7 \ - [list load [file join $dir tcl9registry13.dll] Registry] -} else { - package ifneeded registry 1.3.7 \ - [list load [file join $dir tclregistry13.dll] Registry] -} +package ifneeded registry 1.4a1 \ + [list load [file join $dir tcl9registry14.dll] Registry] diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index d0bd419..5585151 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -30,7 +30,7 @@ namespace eval tcltest { variable patchLevel [info patchlevel] # Detect if we can use code points >= \U10000 - variable fullutf [package vsatisfies $version 9.0-] + variable fullutf [package vsatisfies $version 8.7-] ##### Export the public tcltest procs; several categories # @@ -3330,7 +3330,7 @@ proc tcltest::viewFile {name {directory ""}} { # construct improperly formed strings in this manner, because it involves # exposing that Tcl uses UTF-8 internally. # -# This function doesn't work any more in Tcl 9.0, since the 'identity' +# This function doesn't work any more in Tcl 8.7, since the 'identity' # is gone (TIP #345) # # Arguments: diff --git a/macosx/README b/macosx/README index c4221e4..dc4b698 100644 --- a/macosx/README +++ b/macosx/README @@ -92,9 +92,9 @@ Detailed Instructions for building with macosx/GNUmakefile - Unpack the Tcl source release archive. - The following instructions assume the Tcl source tree is named "tcl${ver}", -(where ${ver} is a shell variable containing the Tcl version number e.g. '9.0'). +(where ${ver} is a shell variable containing the Tcl version number e.g. '9.1'). Setup this shell variable as follows: - ver="9.0" + ver="9.1" - Setup environment variables as desired, for example: CFLAGS="-arch x86_64 -arch arm64 -mmacosx-version-min=10.13" diff --git a/macosx/tclMacOSXFCmd.c b/macosx/tclMacOSXFCmd.c index d8c6b1c..68cc06b 100644 --- a/macosx/tclMacOSXFCmd.c +++ b/macosx/tclMacOSXFCmd.c @@ -70,11 +70,11 @@ static int SetOSTypeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static void UpdateStringOfOSType(Tcl_Obj *objPtr); static const Tcl_ObjType tclOSTypeType = { - "osType", /* name */ - NULL, /* freeIntRepProc */ - NULL, /* dupIntRepProc */ - UpdateStringOfOSType, /* updateStringProc */ - SetOSTypeFromAny, /* setFromAnyProc */ + "osType", /* name */ + NULL, /* freeIntRepProc */ + NULL, /* dupIntRepProc */ + UpdateStringOfOSType, /* updateStringProc */ + SetOSTypeFromAny, /* setFromAnyProc */ TCL_OBJTYPE_V0 }; @@ -120,10 +120,10 @@ typedef struct { int TclMacOSXGetFileAttribute( - Tcl_Interp *interp, /* The interp we are using for errors. */ - int objIndex, /* The index of the attribute. */ - Tcl_Obj *fileName, /* The name of the file (UTF-8). */ - Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */ + Tcl_Interp *interp, /* The interp we are using for errors. */ + int objIndex, /* The index of the attribute. */ + Tcl_Obj *fileName, /* The name of the file (UTF-8). */ + Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */ { #ifdef HAVE_GETATTRLIST int result; @@ -636,7 +636,8 @@ SetOSTypeFromAny( Tcl_Size length; string = TclGetStringFromObj(objPtr, &length); - Tcl_UtfToExternalDStringEx(NULL, encoding, string, length, TCL_ENCODING_PROFILE_TCL8, &ds, NULL); + Tcl_UtfToExternalDStringEx(NULL, encoding, string, length, + TCL_ENCODING_PROFILE_TCL8, &ds, NULL); if (Tcl_DStringLength(&ds) > 4) { if (interp) { @@ -651,9 +652,9 @@ SetOSTypeFromAny( memcpy(bytes, Tcl_DStringValue(&ds), Tcl_DStringLength(&ds)); osType = (OSType) bytes[0] << 24 | - (OSType) bytes[1] << 16 | - (OSType) bytes[2] << 8 | - (OSType) bytes[3]; + (OSType) bytes[1] << 16 | + (OSType) bytes[2] << 8 | + (OSType) bytes[3]; TclFreeInternalRep(objPtr); objPtr->internalRep.wideValue = (Tcl_WideInt) osType; objPtr->typePtr = &tclOSTypeType; @@ -684,7 +685,7 @@ SetOSTypeFromAny( static void UpdateStringOfOSType( - Tcl_Obj *objPtr) /* OSType object whose string rep to + Tcl_Obj *objPtr) /* OSType object whose string rep to * update. */ { const size_t size = TCL_UTF_MAX * 4; diff --git a/macosx/tclMacOSXNotify.c b/macosx/tclMacOSXNotify.c index 3c3f923..d096b35 100644 --- a/macosx/tclMacOSXNotify.c +++ b/macosx/tclMacOSXNotify.c @@ -161,7 +161,7 @@ typedef struct FileHandler { * for this file. */ Tcl_FileProc *proc; /* Function to call, in the style of * Tcl_CreateFileHandler. */ - void *clientData; /* Argument to pass to proc. */ + void *clientData; /* Argument to pass to proc. */ struct FileHandler *nextPtr;/* Next in list of all files we care about. */ } FileHandler; @@ -296,7 +296,7 @@ static ThreadSpecificData *waitingListPtr = NULL; */ static int triggerPipe = -1; -static int receivePipe = -1; /* Output end of triggerPipe */ +static int receivePipe = -1; /* Output end of triggerPipe */ /* * The following static indicates if the notifier thread is running. @@ -822,7 +822,7 @@ TclpAlertNotifier( void TclpSetTimer( - const Tcl_Time *timePtr) /* Timeout value, may be NULL. */ + const Tcl_Time *timePtr) /* Timeout value, may be NULL. */ { ThreadSpecificData *tsdPtr; CFRunLoopTimerRef runLoopTimer; @@ -936,7 +936,7 @@ TclpCreateFileHandler( * called. */ Tcl_FileProc *proc, /* Function to call for each selected * event. */ - void *clientData) /* Arbitrary data to pass to proc. */ + void *clientData) /* Arbitrary data to pass to proc. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); FileHandler *filePtr = LookUpFileHandler(tsdPtr, fd, NULL); @@ -1183,7 +1183,7 @@ TclpNotifierData(void) int TclpWaitForEvent( - const Tcl_Time *timePtr) /* Maximum block time, or NULL. */ + const Tcl_Time *timePtr) /* Maximum block time, or NULL. */ { int result, polling, runLoopRunning; CFTimeInterval waitTime; diff --git a/tests/abstractlist.test b/tests/abstractlist.test index 79c30fb..dda55e3 100644 --- a/tests/abstractlist.test +++ b/tests/abstractlist.test @@ -245,9 +245,9 @@ test abstractlist-3.3 {shimmer lrange} {testobj lstring} { set start [expr {$i+1}] set w }] - set l-isa3 [testobj objtype $l]; # lrange defaults to list behavior + set l-isa3 [testobj objtype $l] list ${l-isa} $il ${l-isa2} ${l-isa3} $words -} {lstring {2 6 10 15 20 25 30 34 40 44 48 55 62 66 74 77 80 85} lstring list {If you can keep your head when all about you Are losing theirs and blaming it on you,}} +} {lstring {2 6 10 15 20 25 30 34 40 44 48 55 62 66 74 77 80 85} lstring lstring {If you can keep your head when all about you Are losing theirs and blaming it on you,}} test abstractlist-3.4 {no shimmer foreach} {testobj lstring} { set l [lstring -not SLICE $str] @@ -307,11 +307,11 @@ test abstractlist-3.7 {no shimmer linsert} {testobj lstring} { test abstractlist-3.8 {shimmer lassign} {testobj lstring} { set l [lstring -not SLICE Inconceivable] set l-isa [testobj objtype $l] - set l2 [lassign $l i n c] ;# must be using lrange internally + set l2 [lassign $l i n c] set l-isa2 [testobj objtype $l] set l2-isa [testobj objtype $l2] list $l ${l-isa} $l2 ${l-isa2} ${l2-isa} -} {{I n c o n c e i v a b l e} lstring {o n c e i v a b l e} list list} +} {{I n c o n c e i v a b l e} lstring {o n c e i v a b l e} lstring list} test abstractlist-3.9 {no shimmer lremove} {testobj lstring} { set l [lstring -not SLICE Inconceivable] diff --git a/tests/assemble.test b/tests/assemble.test index aaeb8a2..fd2a3f6 100644 --- a/tests/assemble.test +++ b/tests/assemble.test @@ -1191,8 +1191,8 @@ test assemble-10.7 {expr - noncompilable} { -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}} } -# assemble-11 - ASSEM_LVT4 (exist, existArray, dictAppend, dictLappend, -# nsupvar, variable, upvar) +# assemble-11 - ASSEM_LVT (exist, existArray, dictAppend, dictLappend, +# nsupvar, variable, upvar) test assemble-11.1 {exist - wrong # args} { -body { @@ -1301,7 +1301,7 @@ test assemble-11.10 {variable} { -cleanup {namespace delete q; rename x {}} } -# assemble-12 - ASSEM_LVT1 (incr and incrArray) +# assemble-12 - ASSEM_LVT (incr and incrArray) test assemble-12.1 {incr - wrong # args} { -body { @@ -1348,20 +1348,8 @@ test assemble-12.5 {incrArray} { -result 8 -cleanup {rename x {}} } -test assemble-12.6 {incr, stupid stack restriction} { - -body { - proc x {} " - [fillTables] - set y 5 - assemble {push 3; incr y} - " - list [catch {x} result] $result $errorCode - } - -result {1 {operand does not fit in one byte} {TCL ASSEM 1BYTE}} - -cleanup {unset result; rename x {}} -} -# assemble-13 -- ASSEM_LVT1_SINT1 - incrImm and incrArrayImm +# assemble-13 -- ASSEM_LVT_SINT1 - incrImm and incrArrayImm test assemble-13.1 {incrImm - wrong # args} { -body { @@ -1439,18 +1427,6 @@ test assemble-13.8 {incrArrayImm} { -result 8 -cleanup {rename x {}} } -test assemble-13.9 {incrImm, stupid stack restriction} { - -body { - proc x {} " - [fillTables] - set y 5 - assemble {incrImm y 3} - " - list [catch {x} result] $result $errorCode - } - -result {1 {operand does not fit in one byte} {TCL ASSEM 1BYTE}} - -cleanup {unset result; rename x {}} -} # assemble-14 -- ASSEM_SINT1 (incrArrayStkImm and incrStkImm) @@ -2371,7 +2347,7 @@ test assemble-23.11 {unsetArrayStk} { -cleanup {rename x {}} } -# assemble-24 -- ASSEM_BOOL_LVT4 (unset; unsetArray) +# assemble-24 -- ASSEM_BOOL_LVT (unset; unsetArray) test assemble-24.1 {unset - wrong # args} { -body { @@ -2900,7 +2876,7 @@ test assemble-30.4 {throw in wrong context} { x } -match glob - -result {1 {"loadScalar1" instruction may not appear in a context where an exception has been caught and not disposed of.} {TCL ASSEM BADTHROW} {{"loadScalar1" instruction may not appear in a context where an exception has been caught and not disposed of.} { in assembly code between lines 10 and 15}*}} + -result {1 {"loadScalar" instruction may not appear in a context where an exception has been caught and not disposed of.} {TCL ASSEM BADTHROW} {{"loadScalar" instruction may not appear in a context where an exception has been caught and not disposed of.} { in assembly code between lines 10 and 15}*}} -cleanup {rename x {}} } test assemble-30.5 {unclosed catch} { @@ -3049,7 +3025,7 @@ test assemble-40.1 {unbalanced stack} { } result] $result $::errorInfo } -result {1 {stack underflow} {stack underflow - in assembly code between lines 1 and end of assembly code*}} + in assembly code between line 1 and end of assembly code*}} -match glob -returnCodes ok } diff --git a/tests/cmdMZ.test b/tests/cmdMZ.test index 3f764a0..4d1ac6f 100644 --- a/tests/cmdMZ.test +++ b/tests/cmdMZ.test @@ -202,7 +202,7 @@ test cmdMZ-return-2.19 {return option handling} -body { } -returnCodes continue -result {} test cmdMZ-return-2.20 {return option handling} { list [catch { - return -level 0 -options {-foo 1} -options {-bar 2} + return -level 0 -options {-foo 1} -options {-bar 2} } -> foo] $foo } {0 {-foo 1 -bar 2 -code 0 -level 0}} test cmdMZ-return-2.21 {return option handling} { diff --git a/tests/coroutine.test b/tests/coroutine.test index 845a4df..3734a1e 100644 --- a/tests/coroutine.test +++ b/tests/coroutine.test @@ -825,6 +825,51 @@ test coroutine-7.14 { return [list $done0 $done1] } -result {failure failure} +test coroutine-7.15 {yieldto and expansion} { + coroutine c apply {{{yieldto yieldto}} { + yield + set abc [list 1 2 3] + set abc [list $abc $abc $abc] + $yieldto string cat {*}$abc + return $abc + }} + list [c] [c] +} {{1 2 31 2 31 2 3} {{1 2 3} {1 2 3} {1 2 3}}} +test coroutine-7.16 {yieldto and expansion} { + coroutine c apply {{} { + yield + set abc [list 1 2 3] + set abc [list $abc $abc $abc] + yieldto string cat {*}$abc + return $abc + }} + list [c] [c] +} {{1 2 31 2 31 2 3} {{1 2 3} {1 2 3} {1 2 3}}} +test coroutine-7.17 {yieldto and expansion} { + coroutine c apply {target { + yield + yieldto {*}$target + return done + }} {list 1 2 "3 4"} + list [c] [c] +} {{1 2 {3 4}} done} +test coroutine-7.18 {yieldto and expansion} -body { + coroutine c apply {{target {yieldto yieldto}} { + yield + $yieldto {*}$target + return done + }} {} + list [c] [c] +} -returnCodes error -result {wrong # args: should be "yieldto command ?arg ...?"} +test coroutine-7.19 {yieldto and expansion} -body { + coroutine c apply {target { + yield + yieldto {*}$target + return done + }} {} + list [c] [c] +} -returnCodes error -result {wrong # args: should be "yieldto command ?arg ...?"} + test coroutine-8.1.1 {coro inject, ticket 42202ba1e5ff566e} -body { interp create child child eval { diff --git a/tests/dict.test b/tests/dict.test index a620b23..fbedd30 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -1667,6 +1667,25 @@ test dict-22.23 {dict with: compiled} { return $a,$b }} } 1,2 +test dict-22.24 {dict with: unicode space body} -setup { + proc \u3000 {} {return IDEOGRAPHICSPACE} +} -body { + apply [list d [list dict with d \u3000]] [dict create a 0] +} -cleanup { + rename \u3000 {} +} -result {IDEOGRAPHICSPACE} +test dict-22.25 {dict with in uplevel: bug fa7995bdf2} { + apply {{} { + set d {p {q {a 1 b 2}}} + apply {{} { + uplevel 1 { + dict with d p q { + string cat "$a,$b" + } + } + }} + }} +} 1,2 proc linenumber {} { dict get [info frame -1] line diff --git a/tests/encoding.test b/tests/encoding.test index 79169cd..90df0dc 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -1186,6 +1186,16 @@ test encoding-31.2 {encoding system on newer Windows always returns utf-8} -body }] } -constraints win -result 1 +test encoding-31.3 {Tcl_GetEncodingNameFromEnvironment} -constraints testencoding -body { + # Primarily tests that stub is callable from outside tcl.{so,dll} via stubs + testencoding Tcl_GetEncodingNameFromEnvironment +} -result [encoding system] + +test encoding-31.4 {Tcl_GetEncodingNameForUser} -constraints testencoding -body { + # Primarily tests that stub is callable from outside tcl.{so,dll} via stubs + testencoding Tcl_GetEncodingNameForUser +} -result [encoding user] + test encoding-bug-6a3e2cb0f0-1 {Bug [6a3e2cb0f0] - invalid bytes in escape encodings} -body { encoding convertfrom -profile tcl8 iso2022-jp x\x1B\x7Aaby } -result x\uFFFDy diff --git a/tests/error.test b/tests/error.test index b432468..f10c1e9 100644 --- a/tests/error.test +++ b/tests/error.test @@ -1195,7 +1195,79 @@ test error-21.9 {Bug cee90e4e88} { # Just don't panic. apply {{} {try {} on ok {} - on return {} {}}} } {} +test error-21.9.1 {Bug cee90e4e88 variant} { + # Just don't panic. + apply {{} {try {} on ok {} - trap return {} {}}} +} {} +test error-22.1 {try trapless} { + apply {{} { + try { + error foo + } on error {} { + incr x + } + return $x + }} +} 1 +test error-22.2 {try trapless} { + apply {{} { + try { + error foo + } on ok {} { + set x gorp + } on error {} { + incr x + } + return $x + }} +} 1 +test error-22.3 {try trapless + finally} { + apply {{} { + try { + error foo + } on error {} { + incr x + } finally { + incr y + } + return $x,$y + }} +} 1,1 +test error-22.4 {try trapless + finally} { + apply {{} { + try { + error foo + } on ok {} { + set x gorp + } on error {} { + incr x + } finally { + incr y + } + return $x,$y + }} +} 1,1 +test error-22.5 {try trapless + finally + empty} { + apply {{} { + try {error foo} on error {} {} finally {} + }} +} {} +test error-22.6 {try trapless + finally + empty} { + apply {{} { + try {error foo} on error {} {} finally {incr x} + }} +} {} +test error-22.7 {try trapless + finally + empty} { + apply {{} { + try {error 1} on error x {} finally {incr x} + }} +} {} +test error-22.8 {try trapless + finally + empty} -body { + apply {{} { + try {error gorp} on error x {} finally {incr x} + }} +} -returnCodes error -result {expected integer but got "gorp"} # negative case try tests - bad "trap" handler # what is the effect if we attempt to trap an errorcode that is not a list? diff --git a/tests/listObj.test b/tests/listObj.test index 087747f..f69b65c 100644 --- a/tests/listObj.test +++ b/tests/listObj.test @@ -240,92 +240,9 @@ proc listobjmemcheck script { expr {$end - $tmp} } -test listobj-12.1 {Tcl_ListObjIndex memory leaks for native lists} -constraints { - testobj memory -} -body { - list [listobjmemcheck { - testobj set 1 [lrepeat 1000 x] - set errorMessage [testlistobj indexmemcheck 1] - testobj freeallvars - }] $errorMessage -} -result {0 {}} -test listobj-12.2 {Tcl_ListObjIndex memory leaks for native lists with spans} -constraints { - testobj memory -} -body { - list [listobjmemcheck { - testobj set 1 [testlistrep new 1000 100 100] - set errorMessage [testlistobj indexmemcheck 1] - testobj freeallvars - }] $errorMessage -} -result {0 {}} -test listobj-12.3 {Tcl_ListObjIndex memory leaks for lseq} -constraints { - testobj memory -} -body { - list [listobjmemcheck { - testobj set 1 [lseq 1000] - set errorMessage [testlistobj indexmemcheck 1] - testobj freeallvars - }] $errorMessage -} -result {0 {}} - -test listobj-13.1 {Tcl_ListObjGetElements memory leaks for native lists} -constraints { - testobj memory -} -body { - list [listobjmemcheck { - testobj set 1 [lrepeat 1000 x] - set errorMessage [testlistobj getelementsmemcheck 1] - testobj freeallvars - }] $errorMessage -} -result {0 {}} -test listobj-13.2 {Tcl_ListObjElements memory leaks for native lists with spans} -constraints { - testobj memory -} -body { - list [listobjmemcheck { - testobj set 1 [testlistrep new 1000 100 100] - set errorMessage [testlistobj getelementsmemcheck 1] - testobj freeallvars - }] $errorMessage -} -result {0 {}} -test listobj-13.3 {Tcl_ListObjElements memory leaks for lseq} -constraints { - testobj memory -} -body { - list [listobjmemcheck { - testobj set 1 [lseq 1000] - set errorMessage [testlistobj getelementsmemcheck 1] - testobj freeallvars - }] $errorMessage -} -result {0 {}} - -# Tests for Tcl_ListObjIndex as sematics are different from lindex for -# out of bounds indices. Out of bounds should return a null pointer and -# not empty string. -test listobj-14.1 {Tcl_ListObjIndex out-of-bounds index for native lists} -constraints { - testobj -} -setup { - testobj set 1 [list a b c] -} -cleanup { - testobj freeallvars -} -body { - list [testlistobj index 1 -1] [testlistobj index 1 3] -} -result {null null} - -test listobj-14.2 {Tcl_ListObjIndex out-of-bounds index for native lists with spans} -constraints { - testobj -} -setup { - testobj set 1 [testlistrep new 1000 100 100] -} -cleanup { - testobj freeallvars -} -body { - list [testlistobj index 1 -1] [testlistobj index 1 1000] -} -result {null null} - -test listobj-14.3 {Tcl_ListObjIndex out-of-bounds index for lseq} -constraints {bug_30e4e9102f testobj} -setup { - testobj set 1 [lseq 3] -} -cleanup { - testobj freeallvars -} -body { - list [testlistobj index 1 -1] [testlistobj index 1 3] -} -result {null null} +# NOTE: listobj-{12,13}.* tests are now memcheck-lindex-* tests in listTypes.test +# where lindex memory checks are done for all list types. +# listobj-14.* tests are now lindex-oob-* in listTypes.test. # cleanup ::tcltest::cleanupTests diff --git a/tests/listRep.test b/tests/listRep.test index d1e08d4..e925029 100644 --- a/tests/listRep.test +++ b/tests/listRep.test @@ -34,6 +34,7 @@ testConstraint testlistrep [llength [info commands testlistrep]] proc describe {l args} {dict get [testlistrep describe $l] {*}$args} proc irange {first last} { + # Do NOT replace this with lseq. Need a non-abstract list. set l {} while {$first <= $last} { lappend l $first diff --git a/tests/listTypes.test b/tests/listTypes.test new file mode 100644 index 0000000..482dd76 --- /dev/null +++ b/tests/listTypes.test @@ -0,0 +1,1503 @@ +# This file tests list command on each internal list representation. +# +# Copyright (c) 2025 Ashok P. Nadkarni +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# In Tcl 9, a list may have one of several list representations. +# - "list" - the basic list (similar to 8.6 implementation) +# - "list" with span - basic list with an attached span specifying a +# contained range. +# - "arithseries" - an abstract list as produced by the lseq command +# - "repeatedList" - an abstract list holding repeated elements +# - "reversedList" - an abstract list that is the reverse of another list +# +# The first three of these are already tested in cmdIL.test, listObj.test, +# lseq.test, listrep.test etc. but are included here to improve coverage of all +# combinations of code paths listed below. The tests in these files do not test +# command options to the commands as those are already tested in the +# aforementioned files. All list operations, loops, {*} expansion need to be +# tested with each of the above types. +# +# Test list operations include combinations of +# - Compiled / uncompiled operation +# - Shared / unshared operands +# - Literal versus variable arguments (only when generated byte instruction differs) +# - List internal representation types. +# as these all vary in the executed code paths. +# +# Some tests assume correct operation on non-abstract lists as they are tested +# independently in other test files. +# +# For the abstract list types not tested elsewhere, +# - verify constructor commands return the expected type +# - generated string representations + +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} + +::tcltest::loadTestedCommands +catch [list package require -exact tcl::test [info patchlevel]] +source [file join [file dirname [info script]] tcltests.tcl] + +testConstraint testobj [llength [info commands testobj]] +testConstraint testlistobj [llength [info commands testobj]] +testConstraint memory [llength [info commands memory]] + +namespace eval listtype { + variable listTypes {arithseries list rangeList repeatedList reversedList spanlist} + variable nestableTypes {list rangeList repeatedList reversedList spanlist} + + # Loop vars etc. + variable ltype + variable ltype1 + variable ltype2 + variable ltype3 + variable first + variable last + variable indices + variable result + variable repeatCount + + # Compiled bytecode depends on whether arguments are literals or + # variables. So test variations are needed for both. + const zero 0 + const minusOne -1 + const ten 10 + + # Internal representation produced by a list operation may depend on list + # length. This is controlled by the *_LENGTH_THRESHOLD values in tclListTypes.c. + # In cases where it matters, assumes a length of smallListLength will always + # be less that these thresholds and largeListLength will be greater. + variable smallListLength 10 + variable largeListLength 120; # Multiple of 4 because of assumptions in tests + + proc getListType {l} { + set ltype [testobj objtype $l] + if {$ltype eq "list"} { + if {[dict exists [testlistrep describe $l] span]} { + return "spanlist" + } + } + return $ltype + } + + # Raise error if list is not the expected type + proc assertListType {l type} { + set ltype [getListType $l] + if {$ltype ne $type} { + error "Assertion failed: list type was \"$ltype\", expected \"$type\"" + } + } + + proc isAbstractList {l} { + return [expr {[getListType $l] ni {list spanlist}}] + } + + # Convert the given list to non abstract + proc makeNonAbstract {l} { + set l [lmap v $l {set v}] + assertListType $l list + return $l + } + + # Returns a list of length $largeListLength of the specified type + proc makeList {type args} { + variable largeListLength + if {[llength $args]} { + set len [lindex $args 0] + } else { + set len $largeListLength + } + set l [switch $type { + list { + testlistrep new $len + } + spanlist { + # Spanned list - force span by leaving 10 empty slots in front + testlistrep new $len 10 + } + arithseries { + lseq $len + } + rangeList { + # lists and arithseries have their own specialized range + # implementations so have to use lreverse or lrepeat + lrange [makeList reversedList [expr $len+1]] 1 end + } + repeatedList { + lrepeat [expr {$len/4}] a b c d + } + reversedList { + lreverse [makeList list $len] + } + }] + assertListType $l $type + return $l + } + + # Returns a non-abstract list with values from a given list type + proc getNonAbstract {type args} { + return [makeNonAbstract [makeList $type {*}$args]] + } + + # Return first and last elements of a list created with makeList + # assuming default lengths passed to makeList. Hardcoded to avoid use of + # list operations as that is what is being tested. + proc getFirstAndLast {ltype} { + variable largeListLength + switch $ltype { + repeatedList { + set first a + set last d + } + rangeList - + reversedList { + set last 0 + set first [expr {$largeListLength-1}] + } + default { + set first 0 + set last [expr {$largeListLength-1}] + } + } + return [list $first $last] + } + + proc makeNestedList {args} { + variable largeListLength + set nestedTypes [lassign $args thisType] + if {[llength $nestedTypes] == 0} { + return [makeList $thisType] + } + set nestedList [makeNestedList {*}$nestedTypes] + return [switch $thisType { + list { + for {set i 0} {$i < $largeListLength} {incr i} { + lappend outerList $nestedList + } + set outerList + } + spanlist { + for {set i 0} {$i < (1+$largeListLength)} {incr i} { + lappend outerList $nestedList + } + # lrange on a list or spanlist will return a spanlist, not rangeList + lrange $outerList 0 end-1 + } + repeatedList { + lrepeat $largeListLength $nestedList + } + reversedList { + for {set i 0} {$i < $largeListLength} {incr i} { + lappend outerList $nestedList + } + lreverse $outerList + } + rangeList { + for {set i 0} {$i < (1+$largeListLength)} {incr i} { + lappend outerList $nestedList + } + # lrange on a list or spanlist will return a spanlist, not rangeList + # so reverse it first. + lrange [lreverse $outerList] 0 end-1 + } + default { + error "List type $thisType cannot nest" + } + }] + } + + # Verify that list constructors return unshared Tcl_Obj's. Otherwise, unshared + # list tests below are invalid. These don't actually test Tcl itself, but rather + # the makeList constructors. + foreach ltype $listTypes { + test ltype-verify-unshared-makeList-$ltype "Verify makeList is unshared" -body { + regexp {refcount of 1,} [tcl::unsupported::representation [makeList $ltype]] + } -result 1 + } + foreach ltype1 $nestableTypes { + foreach ltype2 $nestableTypes { + foreach ltype3 $listTypes { + test ltype-verify-makeNestedList-$ltype1-$ltype2-$ltype3 "Verify makeNestedList" -body { + set l [makeNestedList $ltype1 $ltype2 $ltype3] + list [getListType $l] [getListType [lindex $l 0]] [getListType [lindex $l 0 0]] + } -result [list $ltype1 $ltype2 $ltype3] + } + } + } + + # Wrapper to generate uncompiled, compiled script, and proc cases for a + # test. If $args does not contain a -body key, $comment is treated as the + # test body + proc testdef {id comment args} { + if {[dict exists $args -body]} { + set body [dict get $args -body] + dict unset args -body + } else { + set body $comment + } + + dict lappend args -constraints testobj + dict append args -cleanup "\nunset -nocomplain l l1 l2 l3 a b c d e f g" + + uplevel 1 [list test $id.uncompiled "$comment (uncompiled)" \ + -body [list testevalex $body] \ + {*}$args] + + uplevel 1 [list test $id.compiled-script "$comment (compiled script)" \ + -body [list try $body] \ + {*}$args] + + # Need to make namespace variables accessible to test body within proc + set procbody [string cat \ + "variable largeListLength\n" \ + "variable smallListLength\n" \ + "variable ltype\n" \ + "variable ltype1\n" \ + "variable ltype2\n" \ + "variable ltype3\n" \ + "variable zero\n" \ + "variable ten\n" \ + "variable minusOne\n" \ + $body] + + dict append args -setup \n[list proc testxproc {} $procbody] + dict append args -cleanup "\nrename testxproc {}" + uplevel 1 [list test $id.proc "$comment (compiled proc)" \ + -body testxproc \ + {*}$args] + } + + # llength + foreach ltype $listTypes { + testdef llength-$ltype-shared-0 "llength of shared type $ltype" -body { + set l [makeList $ltype] + list [getListType $l] [llength $l] + } -result [list $ltype $largeListLength] + + testdef llength-$ltype-unshared-0 "llength of unshared type $ltype" -body { + llength [makeList $ltype] + } -result $largeListLength + } + + ################################################################ + # lindex tests - single index + foreach ltype $listTypes { + lassign [getFirstAndLast $ltype] first last + + testdef lindex-$ltype-shared-litarg-0 "lindex 0 of shared type $ltype" -body { + set l [makeList $ltype] + list [getListType $l] [lindex $l 0] + } -result [list $ltype $first] + + testdef lindex-$ltype-shared-vararg-0 "lindex $zero of shared type $ltype" -body { + set l [makeList $ltype] + list [getListType $l] [lindex $l $zero] + } -result [list $ltype $first] + + testdef lindex-$ltype-unshared-litarg-0 "lindex 0 of unshared type $ltype" -body { + lindex [makeList $ltype] 0 + } -result $first + + testdef lindex-$ltype-unshared-vararg-0 "lindex $zero of unshared type $ltype" -body { + lindex [makeList $ltype] $zero + } -result $first + + testdef lindex-$ltype-shared-1 "lindex end of shared type $ltype" -body { + set l [makeList $ltype] + list [getListType $l] [lindex $l end] + } -result [list $ltype $last] + + testdef lindex-$ltype-unshared-1 "lindex end of unshared type $ltype" -body { + lindex [makeList $ltype] end + } -result $last + + testdef lindex-$ltype-shared-2 "lindex -1 of shared type $ltype" -body { + set l [makeList $ltype] + list [getListType $l] [lindex $l -1] + } -result [list $ltype {}] + + testdef lindex-$ltype-unshared-2 "lindex -1 of unshared type $ltype" -body { + lindex [makeList $ltype] -1 + } -result {} + + testdef lindex-$ltype-shared-3 "lindex last of shared type $ltype" -body { + set l [makeList $ltype] + list [getListType $l] [lindex $l [llength $l]] + } -result [list $ltype {}] + + testdef lindex-$ltype-unshared-3 "lindex last of unshared type $ltype" -body { + lindex [makeList $ltype] $largeListLength + } -result {} + + testdef lindex-$ltype-bad-index "lindex $ltype bad index" -body { + lindex [makeList $ltype] badindex + } -result {bad index "badindex": must be integer?[+-]integer? or end?[+-]integer?} -returnCodes error + } + + # lindex tests - nested indices, both single indices arg and multiple args forms + foreach ltype1 $nestableTypes { + foreach ltype2 $nestableTypes { + foreach ltype3 $listTypes { + lassign [getFirstAndLast $ltype3] first last + foreach {indices result} [list \ + {0 0 0} $first \ + {0 0 end} $last \ + {0 0 -1} {} \ + [list 0 0 $largeListLength] {} \ + {0 -1 0} {} \ + [list 0 $largeListLength 0] {} \ + ] { + testdef lindex-nested-onearg-$ltype1-$ltype2-$ltype3-[join $indices ,] "lindex nested single indices argument $ltype1 $ltype2 $ltype3 $indices" \ + -body { + variable indices + lindex [makeNestedList $ltype1 $ltype2 $ltype3] $indices + } -result $result + + testdef lindex-nested-multiarg-$ltype1-$ltype2-$ltype3-[join $indices ,] "lindex nested multiple index arguments $ltype1 $ltype2 $ltype3 $indices" \ + -body { + variable indices + lindex [makeNestedList $ltype1 $ltype2 $ltype3] {*}$indices + } -result $result + } + } + } + } + + # Tests for Tcl_ListObjIndex as sematics are different from lindex for + # out of bounds (oob) indices. Out of bounds should return a null pointer and + # not empty string. + foreach ltype $listTypes { + test lindex-oob-$ltype "Tcl_ListObjIndex out of bounds index for $ltype lists" -setup { + set l [makeList $ltype] + testobj set 1 $l + set len [llength $l] + } -body { + list [lindex $l -1] [lindex $l $len] \ + [testlistobj index 1 -1] [testlistobj index 1 $len] + } -cleanup { + testobj freeallvars + unset -nocomplain l len + } -result [list {} {} null null] + } + + ################################################################ + # lappend tests + # lappend result is always a non-abstract list. All the tests below do is + # confirm abstract lists are converted to non-abstract and appended to + # and further that in the case of shared objects, they are not changed + # or shimmered. + # Test variations of lappend (multiple args etc) are not tested here. + # See listObj.test and listRep.test for those. + foreach ltype $listTypes { + testdef lappend-$ltype-unshared "lappend to unshared list of type $ltype " -body { + set result {} + set l [makeList $ltype] + lappend result [getListType $l] + lappend result [testobj objrefcount $l]; # 2 -> 1 for var l + 1 for arg + lappend l X + lappend result [getListType $l] + lappend result [testobj objrefcount $l]; # 2 -> 1 for var l + 1 for arg + lappend result [string equal $l [string cat [makeList $ltype] " X"]] + } -result [list $ltype 2 [expr {$ltype eq "spanlist" ? "spanlist" : "list"}] 2 1] + + testdef lappend-$ltype-shared "lappend to shared list of type $ltype" -body { + set result {} + set l [makeList $ltype] + set l2 $l + lappend result [getListType $l] + lappend result [testobj objrefcount $l]; # 3: l, l2, arg + lappend result [testobj objrefcount $l2]; # ditto + lappend l X + lappend result [getListType $l]; # Will be list/spanlist + lappend result [getListType $l2]; # Should not have changed + lappend result [testobj objrefcount $l]; # Should drop by 1 + lappend result [testobj objrefcount $l2]; # Should drop by 1 + lappend result [string equal $l [string cat [makeList $ltype] " X"]] + lappend result [string equal $l2 [makeList $ltype]] + } -result [list $ltype 3 3 [expr {$ltype eq "spanlist" ? "spanlist" : "list"}] $ltype 2 2 1 1] + } + + ################################################################ + # lassign tests + # The result of an lassign may be + # - a list (small operand lengths) + # - a spanlist (large operand lengths) + # - arithseries (for arithseries operand) + # - lrangeType (for operands other than lists, spanlists and arithseries) + foreach ltype $listTypes { + lassign [getFirstAndLast $ltype] first last + switch $ltype { + list - spanlist {set ltype2 spanlist} + arithseries {set ltype2 arithseries} + default {set ltype2 rangeList} + } + + testdef lassign-$ltype-unshared "lassign unshared list of type $ltype" -body { + set l [lassign [makeList $ltype] x] + list [getListType $l] $l $x + } -result [list $ltype2 [lrange [makeList $ltype] 1 end] $first] + + testdef lassign-$ltype-shared "lassign shared list of type $ltype" -body { + set l0 [makeList $ltype] + set l [lassign $l0 x] + # The shared value should not shimmer + list [getListType $l0] $l0 [getListType $l] $l $x + } -result [list $ltype [makeList $ltype] $ltype2 [lrange [makeList $ltype] 1 end] $first] + + # Except for arithseries, all small ranges are basic lists + testdef lassign-$ltype-smalllist "lassign small list of type $ltype should always be non-abstract list" -body { + set l [lassign [makeList $ltype 100] x] + list [getListType $l] $l $x + } -result [list [expr {$ltype eq "arithseries" ? "arithseries" : "list"}] [lrange [makeList $ltype 100] 1 end] [lindex [makeList $ltype 100] 0]] + } + + ################################################################ + # ledit tests + # Any modification operation will result in a shimmer to a list or spanlist. + # General variations of ledit operations on lists and spanlists are tested + # in lreplace.test. + foreach ltype $listTypes { + # prepend an element + set expected [list X {*}[makeList $ltype]] + testdef ledit-$ltype-prepend-unshared "ledit -1 -1 unshared $ltype shimmers to list" -body { + set l [makeList $ltype] + list [ledit l -1 -1 X] [isAbstractList $l] $l + } -result [list $expected 0 $expected] + testdef ledit-$ltype-prepend-shared "ledit -1 -1 shared $ltype shimmers to list" -body { + set l [makeList $ltype] + set l2 $l + list [ledit l -1 -1 X] [isAbstractList $l] $l [getListType $l2] $l2 + } -result [list $expected 0 $expected $ltype [makeList $ltype]] + + # append an element + set expected [list {*}[makeList $ltype] X] + testdef ledit-$ltype-append-unshared "ledit end+1 end unshared $ltype shimmers to list" -body { + set l [makeList $ltype] + list [ledit l end+1 end X] [isAbstractList $l] $l + } -result [list $expected 0 $expected] + testdef ledit-$ltype-append-shared "ledit end+1 end+1 shared $ltype shimmers to list" -body { + set l [makeList $ltype] + set l2 $l + list [ledit l end+1 end+1 X] [isAbstractList $l] $l [getListType $l2] $l2 + } -result [list $expected 0 $expected $ltype [makeList $ltype]] + + # replace an element + set expected [list X {*}[lrange [makeList $ltype] 1 end]] + testdef ledit-$ltype-replace-unshared "ledit 0 0 unshared $ltype shimmers to list" -body { + set l [makeList $ltype] + list [ledit l 0 0 X] [isAbstractList $l] $l + } -result [list $expected 0 $expected] + testdef ledit-$ltype-replace-shared "ledit 0 0 shared $ltype shimmers to list" -body { + set l [makeList $ltype] + set l2 $l + list [ledit l 0 0 X] [isAbstractList $l] $l [getListType $l2] $l2 + } -result [list $expected 0 $expected $ltype [makeList $ltype]] + + # Remove an element + set expected [list {*}[makeList $ltype]] + set expected [list {*}[lrange $expected 0 9] {*}[lrange $expected 11 end]] + testdef ledit-$ltype-remove-unshared "ledit 10 10 unshared $ltype shimmers to list" -body { + set l [makeList $ltype] + list [ledit l 10 10] [isAbstractList $l] $l + } -result [list $expected 0 $expected] + testdef ledit-$ltype-remove-shared "ledit 10 10 shared $ltype shimmers to list" -body { + set l [makeList $ltype] + set l2 $l + list [ledit l 10 10] [isAbstractList $l] $l [getListType $l2] $l2 + } -result [list $expected 0 $expected $ltype [makeList $ltype]] + + } + + ################################################################ + # lreplace tests + # Any modification operation will result in a shimmer to a list or spanlist. + # General variations of lreplace operations on lists and spanlists are tested + # in lreplace.test. + foreach ltype $listTypes { + # prepend an element + set expected [list X {*}[makeList $ltype]] + testdef lreplace-$ltype-prepend-unshared "lreplace -1 -1 unshared $ltype shimmers to list" -body { + set l [lreplace [makeList $ltype] -1 -1 X] + list [isAbstractList $l] $l + } -result [list 0 $expected] + testdef lreplace-$ltype-prepend-shared "lreplace -1 -1 shared $ltype shimmers to list" -body { + set l2 [makeList $ltype] + set l [lreplace $l2 -1 -1 X] + list [isAbstractList $l] $l [getListType $l2] $l2 + } -result [list 0 $expected $ltype [makeList $ltype]] + + # append an element + set expected [list {*}[makeList $ltype] X] + testdef lreplace-$ltype-append-unshared "lreplace end+1 end unshared $ltype shimmers to list" -body { + set l [lreplace [makeList $ltype] end+1 end X] + list [isAbstractList $l] $l + } -result [list 0 $expected] + testdef lreplace-$ltype-append-shared "lreplace end+1 end+1 shared $ltype shimmers to list" -body { + set l2 [makeList $ltype] + set l [lreplace $l2 end+1 end+1 X] + list [isAbstractList $l] $l [getListType $l2] $l2 + } -result [list 0 $expected $ltype [makeList $ltype]] + + # replace an element + set expected [list X {*}[lrange [makeList $ltype] 1 end]] + testdef lreplace-$ltype-replace-unshared "lreplace 0 0 unshared $ltype shimmers to list" -body { + set l [lreplace [makeList $ltype] 0 0 X] + list [isAbstractList $l] $l + } -result [list 0 $expected] + + testdef lreplace-$ltype-replace-shared "lreplace 0 0 shared $ltype shimmers to list" -body { + set l2 [makeList $ltype] + set l [lreplace $l2 0 0 X] + list [isAbstractList $l] $l [getListType $l2] $l2 + } -result [list 0 $expected $ltype [makeList $ltype]] + + # Remove an element + set expected [list {*}[makeList $ltype]] + set expected [list {*}[lrange $expected 0 9] {*}[lrange $expected 11 end]] + testdef lreplace-$ltype-remove-unshared "lreplace 10 10 unshared $ltype shimmers to list" -body { + set l [lreplace [makeList $ltype] 10 10] + list [isAbstractList $l] $l + } -result [list 0 $expected] + testdef lreplace-$ltype-remove-shared "lreplace 10 10 shared $ltype shimmers to list" -body { + set l2 [makeList $ltype] + set l [lreplace $l2 10 10] + list [isAbstractList $l] $l [getListType $l2] $l2 + } -result [list 0 $expected $ltype [makeList $ltype]] + + } + + ################################################################ + # linsert tests + # Any modification operation will result in a shimmer to a list or spanlist. + # These are then covered in linsert.test and listRep.test + foreach ltype $listTypes { + # linsert at 0 + set expected [list X {*}[makeList $ltype]] + testdef linsert-$ltype-prepend-unshared "linsert 0 unshared $ltype shimmers to list" -body { + set l [linsert [makeList $ltype] 0 X] + list [isAbstractList $l] $l + } -result [list 0 $expected] + testdef linsert-$ltype-prepend-shared "linsert 0 shared $ltype shimmers to list" -body { + set l2 [makeList $ltype] + set l [linsert $l2 0 X] + list [isAbstractList $l] $l [getListType $l2] $l2 + } -result [list 0 $expected $ltype [makeList $ltype]] + + # append an element + set expected [list {*}[makeList $ltype] X] + testdef linsert-$ltype-append-unshared "linsert end+1 unshared $ltype shimmers to list" -body { + set l [linsert [makeList $ltype] end+1 X] + list [isAbstractList $l] $l + } -result [list 0 $expected] + testdef linsert-$ltype-append-shared "linsert end+1 shared $ltype shimmers to list" -body { + set l2 [makeList $ltype] + set l [linsert $l2 end+1 X] + list [isAbstractList $l] $l [getListType $l2] $l2 + } -result [list 0 $expected $ltype [makeList $ltype]] + + # insert multiple elements + set expected [list {*}[makeList $ltype]] + set expected [list {*}[lrange $expected 0 9] X Y {*}[lrange $expected 10 end]] + testdef linsert-$ltype-multiple-unshared "linsert multiple unshared $ltype shimmers to list" -body { + set l [linsert [makeList $ltype] 10 X Y] + list [isAbstractList $l] $l + } -result [list 0 $expected] + testdef linsert-$ltype-multiple-shared "linsert multiple shared $ltype shimmers to list" -body { + set l2 [makeList $ltype] + set l [linsert $l2 10 X Y] + list [isAbstractList $l] $l [getListType $l2] $l2 + } -result [list 0 $expected $ltype [makeList $ltype]] + } + + ################################################################ + # lsearch tests + # Will shimmer to a list or spanlist. + foreach ltype $listTypes { + testdef lsearch-$ltype "lsearch $ltype" -body { + set l [makeList $ltype] + set needle [lindex $l 10] + list [expr { + [lsearch $l $needle] == [lsearch [makeNonAbstract $l] $needle] + }] [isAbstractList $l] + } -result [list 1 [expr {$ltype eq "arithseries" ? 1 : 0}]] + } + + ################################################################ + # lset tests + # Any modification operation will result in a shimmer to a list or spanlist. + foreach ltype $listTypes { + set expected [makeNonAbstract [makeList $ltype]] + set expected [list {*}[lrange $expected 0 9] X {*}[lrange $expected 11 end]] + testdef lset-$ltype-unshared "lset 0 unshared" -body { + set l [makeList $ltype] + list [lset l 10 X] [isAbstractList $l] + } -result [list $expected 0] + testdef lset-$ltype-shared "lset 0 shared" -body { + set l2 [makeList $ltype] + set l $l2 + list [lset l 10 X] [isAbstractList $l] $l2 [getListType $l2] + } -result [list $expected 0 [makeList $ltype] $ltype] + + # appending is a special case + set expected [makeNonAbstract [makeList $ltype]] + lappend expected X + testdef lset-$ltype-unshared-append "lset end+1 unshared" -body { + set l [makeList $ltype] + list [lset l end+1 X] [isAbstractList $l] + } -result [list $expected 0] + testdef lset-$ltype-shared-first "lset end+1 shared" -body { + set l2 [makeList $ltype] + set l $l2 + list [lset l end+1 X] [isAbstractList $l] $l2 [getListType $l2] + } -result [list $expected 0 [makeList $ltype] $ltype] + + } + # lset - nested indices + foreach ltype1 $nestableTypes { + foreach ltype2 $nestableTypes { + foreach ltype3 $listTypes { + foreach {indices resultIndices} \ + [list \ + {0 0 0} {0 0 0} \ + {10 10 10} {10 10 10} \ + {end end end} {end end end} \ + {end+1 end+1 end+1} {end end end} \ + ] { + testdef lset-nested-onearg-$ltype1-$ltype2-$ltype3-[join $indices ,] \ + "lset nested single indices argument $ltype1 $ltype2 $ltype3 $indices" \ + -body { + variable indices + variable resultIndices + set l [makeNestedList $ltype1 $ltype2 $ltype3] + lset l $indices X + list [isAbstractList $l] [lindex $l $resultIndices] + } -result {0 X} + + testdef lset-nested-multiarg-$ltype1-$ltype2-$ltype3-[join $indices ,] "lset nested multiple index arguments $ltype1 $ltype2 $ltype3 $indices" \ + -body { + variable indices + variable resultIndices + set l [makeNestedList $ltype1 $ltype2 $ltype3] + lset l {*}$indices X + list [isAbstractList $l] [lindex $l $resultIndices] + } -result {0 X} + } + } + } + } + + ################################################################ + # lsort tests + # Test not correctness but rather that sorts same as non-abstract sort + # which is presumably correct. + foreach ltype $listTypes { + testdef lsort-$ltype-unshared "lsort unshared $ltype" -body { + set l [lsort [makeList $ltype]] + list [isAbstractList $l] $l + } -result [list 0 [lsort [makeNonAbstract [makeList $ltype]]]] + + testdef lsort-$ltype-shared "lsort unshared $ltype" -body { + set l2 [makeList $ltype] + set l [lsort $l2] + # Note: $l2 is shimmered by lsort. + # TODO - consider changing lsort to not shimmer its argument. + list [isAbstractList $l] $l $l2 + } -result [list 0 [lsort [makeNonAbstract [makeList $ltype]]] [makeList $ltype]] + testdef lsort-$ltype-unshared-decreasing "lsort -decreasing unshared $ltype" -body { + set l [lsort -decreasing [makeList $ltype]] + list [isAbstractList $l] $l + } -result [list 0 [lsort -decreasing [makeNonAbstract [makeList $ltype]]]] + + testdef lsort-$ltype-shared-decreasing "lsort unshared $ltype" -body { + set l2 [makeList $ltype] + set l [lsort -decreasing $l2] + # Note: $l2 is shimmered by lsort. + # TODO - consider changing lsort to not shimmer its argument. + list [isAbstractList $l] $l $l2 + } -result [list 0 [lsort -decreasing [makeNonAbstract [makeList $ltype]]] [makeList $ltype]] + } + + ################################################################ + # foreach tests + foreach ltype $listTypes { + testdef foreach-$ltype-unshared "foreach unshared $ltype" -body { + set l {} + foreach v [makeList $ltype] { + lappend l $v + } + set l + } -result [makeList $ltype] + testdef foreach-$ltype-shared "foreach shared $ltype" -body { + set l [makeList $ltype] + set l2 {} + foreach v $l { + lappend l2 $v + } + list [getListType $l] $l [getListType $l2] $l2 + } -result [list $ltype [makeList $ltype] list [makeList $ltype]] + testdef foreach-$ltype-empty-elements "foreach $ltype empty elements" -body { + set l {} + foreach {a b c d e f g} [makeList $ltype] { + lappend l $a $b $c $d $e $f $g + } + set l + } -result [list {*}[makeList $ltype] {*}[lrepeat [expr (7-$largeListLength%7)] {}]] + } + + ################################################################ + # lmap tests + # Aside from correct results, should not shimmer original + foreach ltype $listTypes { + testdef lmap-$ltype-unshared "lmap unshared $ltype" -body { + lmap v [makeList $ltype] { + set v + } + } -result [makeList $ltype] + testdef lmap-$ltype-shared "lmap shared $ltype" -body { + set l [makeList $ltype] + set l2 [lmap v $l { + set v + }] + list [getListType $l] $l [getListType $l2] $l2 + } -result [list $ltype [makeList $ltype] list [makeList $ltype]] + testdef lmap-$ltype-empty-elements "lmap $ltype empty elements" -body { + concat {*}[lmap {a b c d e f g} [makeList $ltype] { + list $a $b $c $d $e $f $g + }] + } -result [list {*}[makeList $ltype] {*}[lrepeat [expr (7-$largeListLength%7)] {}]] + + } + + ################################################################ + # concat tests + # TODO - the concat command shimmers all args except first because it calls + # Tcl_ListObjAppendList under the covers. Should fix to not shimmer and then + # add a check in test below for that. + foreach ltype1 $listTypes { + foreach ltype2 $listTypes { + testdef concat-$ltype1-$ltype2 "concat $ltype1 $ltype2" -body { + set l1 [makeList $ltype1] + set l2 [makeList $ltype2] + list \ + [concat $l1 $l2] \ + [getListType $l1] + } -result [list [concat [getNonAbstract $ltype1] [getNonAbstract $ltype2]] $ltype1] + } + } + + ################################################################ + # join tests + # TODO - join shimmers its argument. Modify to avoid and add a check + # to the test below. + foreach ltype $listTypes { + testdef join-$ltype "join $ltype" -body { + set l [makeList $ltype] + join $l , + } -result [join [getNonAbstract $ltype] ,] + } + + ################################################################ + # lpop tests + # Always shimmers to non-abstract list. + foreach ltype $listTypes { + lassign [getFirstAndLast $ltype] first last + testdef lpop-$ltype-noargs "lpop $ltype" -body { + set l [makeList $ltype] + list [lpop l] [isAbstractList $l] $l + } -result [list $last 0 [lrange [getNonAbstract $ltype] 0 end-1]] + testdef lpop-$ltype-first "lpop $ltype 0" -body { + set l [makeList $ltype] + list [lpop l 0] [isAbstractList $l] $l + } -result [list $first 0 [lrange [getNonAbstract $ltype] 1 end]] + + testdef lpop-$ltype-middle "lpop $ltype 10" -body { + set l [makeList $ltype] + list [lpop l 10] [isAbstractList $l] $l + } -result [list [lindex [makeList $ltype] 10] \ + 0 \ + [list \ + {*}[lrange [getNonAbstract $ltype] 0 9] \ + {*}[lrange [getNonAbstract $ltype] 11 end]]] + } + + # lpop - nested indices + # Only two levels. Three levels takes too long with memdbg or valgrind + foreach ltype1 $nestableTypes { + foreach ltype2 $listTypes { + lassign [getFirstAndLast $ltype2] first last + foreach indices [list {0 0} {3 3} {end end} ] { + set index [lindex $indices 0] + set expected [makeNestedList $ltype1 $ltype2] + set elem [lindex $expected $indices] + set inner [lindex $expected [lindex $indices 0]] + set inner [lremove $inner $index] + lset expected [lindex $indices 0] $inner + testdef lpop-nested-$ltype1-$ltype2-[join $indices ,] \ + "lpop nested multiple index arguments $ltype1 $ltype2 $indices" \ + -body { + variable indices + set l [makeNestedList $ltype1 $ltype2] + list [lpop l {*}$indices] $l + } -result [list $elem $expected] + } + } + } + + ################################################################ + # lremove tests + # First, last and middle are tested separately as they have + # different code paths. + foreach ltype $listTypes { + # Remove first + set expected [makeNonAbstract [lrange [makeList $ltype] 1 end]] + testdef lremove-$ltype-first-unshared "lremove 0 unshared $ltype shimmers to list" -body { + set l [lremove [makeList $ltype] 0] + list [isAbstractList $l] $l + } -result [list 0 $expected] + testdef lremove-$ltype-first-shared "lremove 0 shared $ltype shimmers to list" -body { + set l2 [makeList $ltype] + set l [lremove $l2 0] + list [isAbstractList $l] $l [getListType $l2] $l2 + } -result [list 0 $expected $ltype [makeList $ltype]] + + # Remove last + set expected [makeNonAbstract [lrange [makeList $ltype] 0 end-1]] + testdef lremove-$ltype-last-unshared "lremove end unshared $ltype shimmers to list" -body { + set l [lremove [makeList $ltype] end] + list [isAbstractList $l] $l + } -result [list 0 $expected] + testdef lremove-$ltype-last-shared "lremove end shared $ltype shimmers to list" -body { + set l2 [makeList $ltype] + set l [lremove $l2 end] + list [isAbstractList $l] $l [getListType $l2] $l2 + } -result [list 0 $expected $ltype [makeList $ltype]] + + # Remove middle + set expected [makeNonAbstract [makeList $ltype]] + set expected [list {*}[lrange $expected 0 9] {*}[lrange $expected 11 end]] + testdef lremove-$ltype-middle-unshared "lremove 10 unshared $ltype shimmers to list" -body { + set l [lremove [makeList $ltype] 10] + list [isAbstractList $l] $l + } -result [list 0 $expected] + testdef lremove-$ltype-middle-shared "lremove 10 shared $ltype shimmers to list" -body { + set l2 [makeList $ltype] + set l [lremove $l2 10] + list [isAbstractList $l] $l [getListType $l2] $l2 + } -result [list 0 $expected $ltype [makeList $ltype]] + + # Remove out of order with duplicates + set expected [makeNonAbstract [makeList $ltype]] + set expected [list {*}[lrange $expected 1 9] \ + {*}[lrange $expected 11 end-12] \ + {*}[lrange $expected end-10 end-1]] + testdef lremove-$ltype-multiple-unshared "lremove multiple unshared $ltype shimmers to list" -body { + set l [lremove [makeList $ltype] end 10 0 end-11 10 end-11] + list [isAbstractList $l] $l + } -result [list 0 $expected] + testdef lremove-$ltype-multiple-shared "lremove multiple shared $ltype shimmers to list" -body { + set l2 [makeList $ltype] + set l [lremove $l2 end 10 0 end-11 10 end-11] + list [isAbstractList $l] $l [getListType $l2] $l2 + } -result [list 0 $expected $ltype [makeList $ltype]] + } + + ################################################################ + # expr in/ni operators + foreach ltype $listTypes { + testdef expr-in-$ltype-first "expr first in/ni list of type $ltype" -body { + set l [makeList $ltype] + list [expr {[lindex $l 0] in $l}] \ + [expr {[lindex $l 0] ni $l}] \ + [getListType $l] + } -result [list 1 0 $ltype] + testdef expr-in-$ltype-last "expr end in/ni list of type $ltype" -body { + set l [makeList $ltype] + list [expr {[lindex $l end] in $l}] \ + [expr {[lindex $l end] ni $l}] \ + [getListType $l] + } -result [list 1 0 $ltype] + testdef expr-in-$ltype-fail "value not in/ni list of type $ltype" -body { + set l [makeList $ltype] + list [expr {"XX" in $l}] \ + [expr {"XX" ni $l}] \ + [getListType $l] + } -result [list 0 1 $ltype] + } + + ################################################################ + # lreverse tests + # + + # Reverse a list to produce a non-abstract list. lreverse will produce + # an abstract list. + proc doReverse {l} { + set r [list ] + foreach v $l { + set r [linsert $r 0 $v] + } + return $r + } + foreach ltype $listTypes { + lassign [getFirstAndLast $ltype] first last + switch $ltype { + reversedList { + # reversing reversedList will give back the original + set expectedType list + } + arithseries { + set expectedType arithseries + } + default { + set expectedType reversedList + } + } + testdef lreverse-$ltype "lreverse $ltype" -body { + set l [lreverse [makeList $ltype]] + list [getListType $l] [lindex $l 0] [lindex $l end] $l + } -result [list $expectedType $last $first [doReverse [makeList $ltype]]] + } + testdef lreverse-small-list "lreverse of small non-abstract list is a non-abstract list" -body { + set l [lreverse [makeList list $smallListLength]] + list [getListType $l] $l + } -result [list list [doReverse [makeList list $smallListLength]]] + + testdef lreverse-small-spanlist "lreverse of small spanlist is a non-abstract list" -body { + set l [lreverse [makeList spanlist $smallListLength]] + list [getListType $l] $l + } -result [list list [doReverse [makeList list $smallListLength]]] + + testdef lreverse-hashchar "Verify string representation of lreverse when first char is #" -body { + set l [lreverse [lrepeat $largeListLength #]] + list [getListType $l] $l + } -result [list reversedList [string cat "{#}" [string repeat " #" [expr {$largeListLength-1}]]]] + + testdef lreverse-brace "Verify string representation of lreverse when first char is brace" -body { + set l [lreverse [lrepeat $largeListLength \{]] + list [getListType $l] $l + } -result [list reversedList [lreverse [makeNonAbstract [lrepeat $largeListLength \{]]]] + + ################################################################ + # lrepeat tests + + testdef lrepeat-zero-count "Verify zero count lrepeat" -body { + set l [lrepeat 0 x y] + list [getListType $l] $l + } -result {none {}} + + testdef lrepeat-zero-arg "Verify zero arg lrepeat" -body { + set l [lrepeat 10] + list [getListType $l] $l + } -result {none {}} + + testdef lrepeat-large "Verify type and string representation of large lrepeat" -body { + set l [lrepeat $largeListLength a "b c"] + list [getListType $l] $l + } -result [list repeatedList [string cat "a {b c}" [string repeat " a {b c}" [expr {$largeListLength-1}]]]] + + # Note code paths for single and multiple args is different so two tests + testdef lrepeat-small-onearg "Verify type and string representation of small lrepeat of single arg" -body { + set l [lrepeat $smallListLength "b c"] + list [getListType $l] $l + } -result [list list [string cat "{b c}" [string repeat " {b c}" [expr {$smallListLength-1}]]]] + + testdef lrepeat-small-multiarg "Verify type and string representation of small lrepeat multiarg" -body { + set l [lrepeat $smallListLength a "b c"] + list [getListType $l] $l + } -result [list list [string cat "a {b c}" [string repeat " a {b c}" [expr {$smallListLength-1}]]]] + + testdef lrepeat-large-hashchar "Verify string representation of large lrepeat when first char is #" -body { + set l [lrepeat $largeListLength # a] + list [getListType $l] $l + } -result [list repeatedList [string cat "{#} a" [string repeat " # a" [expr {$largeListLength-1}]]]] + + testdef lrepeat-small-hashchar "Verify string representation of small lrepeat when first char is #" -body { + set l [lrepeat $smallListLength # a] + list [getListType $l] $l + } -result [list list [string cat "{#} a" [string repeat " # a" [expr {$smallListLength-1}]]]] + + testdef lrepeat-large-brace "Verify string representation of large lrepeat when first char is brace" -body { + set l [lrepeat $largeListLength \{] + list [getListType $l] [string equal $l [string cat "\\\{" [string repeat " \\\{" [expr {$largeListLength-1}]]]] + } -result {repeatedList 1} + + testdef lrepeat-small-brace "Verify string representation of small lrepeat when first char is brace" -body { + set l [lrepeat $smallListLength \{] + list [getListType $l] [string equal $l [string cat "\\\{" [string repeat " \\\{" [expr {$smallListLength-1}]]]] + } -result {list 1} + + ################################################################ + # lrange tests + # The result of an lrange may be + # - a list (small operand lengths) + # - a spanlist (large operand lengths) + # - arithseries (for arithseries operand) + # - lrangeType (for operands other than lists, spanlists and arithseries) + # These tests depend on correct operation of lrange on non-abstract lists + # (tested elsewhere) + + foreach ltype $listTypes { + switch $ltype { + list - spanlist {set ltype2 spanlist} + arithseries {set ltype2 arithseries} + default {set ltype2 rangeList} + } + + testdef lrange-$ltype-unshared "lrange unshared list of type $ltype" -body { + set l [lrange [makeList $ltype] 1 end-1] + list [getListType $l] $l + } -result [list $ltype2 [lrange [getNonAbstract $ltype] 1 end-1]] + + testdef lrange-$ltype-shared "lrange shared list of type $ltype" -body { + set l0 [makeList $ltype] + set l [lrange $l0 1 [expr {$largeListLength-2}]] + # The shared value should not shimmer + list [getListType $l0] $l0 [getListType $l] $l + } -result [list \ + $ltype \ + [makeList $ltype] $ltype2 [lrange [makeList $ltype] 1 end-1]] + + # Except for arithseries, all small ranges are basic lists + testdef lrange-$ltype-smalllist "lrange small list of type $ltype" -body { + set l [lrange [makeList $ltype] 1 10] + list [getListType $l] $l + } -result [list \ + [expr {$ltype eq "arithseries" ? "arithseries" : "list"}] \ + [lrange [getNonAbstract $ltype] 1 10]] + } + + ################################################################ + # Raw C API tests + + # Tcl_ListObjRepeat + # + # - refCount of result is checked for 0 but that is not by + # API contract but is expected for current implementation. + # - on invalid counts, returned Tcl_Obj * is set to NULL but + # that is again not by contract, but current implementation + # so unchecked return status is caught early. + + test Tcl_ListObjRepeat-repeat0-noargs { + Tcl_ListObjRepeat 0 + } -body { + set apiresult [testlistapi Tcl_ListObjRepeat 0] + dict with apiresult {} + list $status $resultRefCount $resultType $result + } -cleanup { + unset -nocomplain {*}[dict keys $apiresult] apiresult + } -result [list 0 0 "" {}] + + test Tcl_ListObjRepeat-repeat0-withargs { + Tcl_ListObjRepeat 0 x y + } -body { + set apiresult [testlistapi Tcl_ListObjRepeat 0 x y] + dict with apiresult {} + list $status $resultRefCount $resultType $result + } -cleanup { + unset -nocomplain {*}[dict keys $apiresult] apiresult + } -result [list 0 0 "" {}] + + test Tcl_ListObjRepeat-repeatN-noargs { + Tcl_ListObjRepeat 10 + } -body { + set apiresult [testlistapi Tcl_ListObjRepeat 10] + dict with apiresult {} + list $status $resultRefCount $resultType $result + } -cleanup { + unset -nocomplain {*}[dict keys $apiresult] apiresult + } -result [list 0 0 "" {}] + + test Tcl_ListObjRepeat-repeat-large { + Tcl_ListObjRepeat with total elements above threshold + } -body { + set apiresult [testlistapi Tcl_ListObjRepeat 20 a b c d e f g h i j] + dict with apiresult {} + list $status $resultRefCount $resultType [join $result ""] + } -cleanup { + unset -nocomplain {*}[dict keys $apiresult] apiresult + } -result [list 0 0 repeatedList [string repeat abcdefghij 20]] + + test Tcl_ListObjRepeat-repeat-small { + Tcl_ListObjRepeat with total elements below threshold + } -body { + set apiresult [testlistapi Tcl_ListObjRepeat 2 a b c d e f g h i j] + dict with apiresult {} + list $status $resultRefCount $resultType [join $result ""] + } -cleanup { + unset -nocomplain {*}[dict keys $apiresult] apiresult + } -result [list 0 0 list [string repeat abcdefghij 2]] + + test Tcl_ListObjRepeat-invalid-repeatcount { + Invalid count should return NULL in resultPtr + } -body { + set apiresult [testlistapi Tcl_ListObjRepeat -1 x] + dict with apiresult {} + list $status $result $resultPtr + } -cleanup { + unset -nocomplain {*}[dict keys $apiresult] apiresult + } -result [list 1 {bad count "-1": must be integer >= 0} 0] + + test Tcl_ListObjRepeat-toolarge-repeatcount { + Too large a count should return NULL in resultPtr + } -body { + set apiresult [testlistapi Tcl_ListObjRepeat \ + [expr {$::tcltests::TCL_SIZE_MAX/2}] x y] + dict with apiresult {} + list $status $result $resultPtr + } -cleanup { + unset -nocomplain {*}[dict keys $apiresult] apiresult + } -result [list 1 {max length * exceeded} 0] -match glob + + # Tcl_ListObjRange + # + # Aside from the correct range result, + # - Source object type must not change (except spanlist->list + # since the type returned at C level is list for both + # list and spanlist) + # - Source object reference counts may increase by at most 1 + # - Result object must not be same as source object even if unshared + # - Small ranges are non-abstract lists + # + # In addition, in the *current* implementation, but not guaranteed + # by the contract in the documented API, + # - $resultRefCount is 0 (i.e. unshared object is returned) + # - on errors, the result Tcl_Obj* is set to NULL + # This may change in a future implementation, in which case the tests + # will have to be modified. + + foreach ltype $listTypes { + switch $ltype { + list - spanlist { + set ltype2 list; # Because the C level does not distinguish + } + arithseries {set ltype2 arithseries} + default {set ltype2 rangeList} + } + # Check normal operation with unshared (0, 1) and shared objects + foreach nrefs {0 1 2} { + test Tcl_ListObjRange-$ltype-nrefs$nrefs \ + "Tcl_ListObjRange for $ltype lists 1 end-1" -body { + set apiresult \ + [testlistapi Tcl_ListObjRange $nrefs \ + [makeList $ltype] 1 [expr {$largeListLength-2}]] + dict with apiresult {} + set srcRefDiff [expr {$srcRefCount-$nrefs}] + list $status [tcl::mathop::<= 0 $srcRefDiff 1] $srcType \ + $resultRefCount $resultType $result \ + [expr {$srcPtr != $resultPtr}] + } -cleanup { + unset -nocomplain {*}[dict keys $apiresult] apiresult + } -result [list 0 1 \ + [expr {$ltype eq "spanlist" ? "list" : $ltype}] \ + 0 $ltype2 \ + [lrange [getNonAbstract $ltype] 1 end-1] \ + 1] + + # Small ranges are always plain old lists + test Tcl_ListObjRange-$ltype-nrefs$nrefs-smalllist \ + "Tcl_ListObjRange for $ltype lists 1 10" -body { + set apiresult [testlistapi Tcl_ListObjRange $nrefs \ + [makeList $ltype] 1 10] + dict with apiresult {} + list $status $srcRefCount $srcType $resultRefCount \ + $resultType $result [expr {$srcPtr != $resultPtr}] + } -cleanup { + unset -nocomplain {*}[dict keys $apiresult] apiresult + } -result [list 0 $nrefs \ + [expr {$ltype eq "spanlist" ? "list" : $ltype}] \ + 0 \ + [expr {$ltype in "arithseries" ? "arithseries" : "list"}] \ + [lrange [getNonAbstract $ltype] 1 10] \ + 1] + } + } + foreach nrefs {0 1 2} { + test Tcl_ListObjRange-invalid-list-$nrefs { + Invalid list should return NULL in resultPtr + } -body { + set apiresult [testlistapi Tcl_ListObjRange $nrefs \{ 0 0] + dict with apiresult {}; # Explode apiresult into status, srcRefCount ... + list $status $srcRefCount $result $resultPtr + } -cleanup { + unset -nocomplain {*}[dict keys $apiresult] apiresult + } -result [list 1 $nrefs {unmatched open brace in list} 0] + } + + #----- + + # Tcl_ListObjReverse + # + # Aside from the correct result, + # - Source object type must not change (except spanlist->list + # since the type returned at C level is list for both + # list and spanlist) + # - Source object reference counts may increase by at most 1 + # - Result object must not be same as source object even if unshared + # - Reverses of small non-abstract lists are non-abstract + # + # In addition, in the *current* implementation, but not guaranteed + # by the contract in the documented API, + # - on errors, the result Tcl_Obj* is set to NULL + # This may change in a future implementation, in which case the tests + # will have to be modified. + + foreach ltype $listTypes { + switch $ltype { + reversedList { + # [makeList reversedList] is itself a reverse of a "list" + set ltype2 list + } + arithseries {set ltype2 arithseries} + default {set ltype2 reversedList} + } + # Check normal operation with unshared (0, 1) and shared objects + foreach nrefs {0 1 2} { + test Tcl_ListObjReverse-$ltype-nrefs$nrefs \ + "Tcl_ListObjReverse for $ltype list" -body { + set apiresult \ + [testlistapi Tcl_ListObjReverse $nrefs [makeList $ltype]] + dict with apiresult {} + set srcRefDiff [expr {$srcRefCount-$nrefs}] + list $status [tcl::mathop::<= 0 $srcRefDiff 1] $srcType \ + $resultType $result \ + [expr {$srcPtr != $resultPtr}] + } -cleanup { + unset -nocomplain {*}[dict keys $apiresult] apiresult + } -result [list 0 1 \ + [expr {$ltype eq "spanlist" ? "list" : $ltype}] \ + $ltype2 \ + [doReverse [getNonAbstract $ltype]] \ + 1] + + if {$ltype in {list spanlist}} { + test Tcl_ListObjReverse-$ltype-nrefs$nrefs-smalllist \ + "Tcl_ListObjReverse for $ltype (small)" -body { + set apiresult [testlistapi Tcl_ListObjReverse $nrefs \ + [makeList $ltype $smallListLength]] + dict with apiresult {} + list $status $srcRefCount $srcType $resultRefCount \ + $resultType $result [expr {$srcPtr != $resultPtr}] + } -cleanup { + unset -nocomplain {*}[dict keys $apiresult] apiresult + } -result [list 0 $nrefs \ + list \ + 0 \ + list \ + [doReverse [getNonAbstract $ltype $smallListLength]] \ + 1] + } + } + } + foreach nrefs {0 1 2} { + test Tcl_ListObjReverse-invalid-list-$nrefs { + Invalid list should return NULL in resultPtr + } -body { + set apiresult [testlistapi Tcl_ListObjReverse $nrefs \{] + dict with apiresult {} + list $status $srcRefCount $result $resultPtr + } -cleanup { + unset -nocomplain {*}[dict keys $apiresult] apiresult + } -result [list 1 $nrefs {unmatched open brace in list} 0] + } + + #----- + + ################################################################ + # Checks for memory leaks in raw C API + # If Tcl has been compiled with memory checking, use it, else will rely + # on valgrind -DPURIFY builds. + if {[namespace which ::memory] eq {}} { + set memcheckcmd [list ::apply [list script { + uplevel 1 $script + return 0 + } [namespace current]]] + } else { + set memcheckcmd ::tcltests::scriptmemcheck + } + + ## Test Tcl_ListObjIndex does not leak memory + + test memcheck-lindex-list { + Tcl_ListObjIndex memory leaks for native lists + } -constraints {testobj} -body { + list [{*}$memcheckcmd { + testobj set 1 [testlistrep new 1000] + assertListType [testobj duplicate 1 2] list + set errorMessage [testlistobj indexmemcheck 1] + testobj freeallvars + }] $errorMessage + } -result {0 {}} + + test memcheck-lindex-spanlist { + Tcl_ListObjIndex memory leaks for native lists + } -constraints {testobj} -body { + list [{*}$memcheckcmd { + testobj set 1 [testlistrep new 1000 10 10] + assertListType [testobj duplicate 1 2] spanlist + set errorMessage [testlistobj indexmemcheck 1] + testobj freeallvars + }] $errorMessage + } -result {0 {}} + + test memcheck-lindex-arithseries { + Tcl_ListObjIndex memory leaks for lseq + } -constraints {testobj} -body { + list [{*}$memcheckcmd { + testobj set 1 [lseq 1000] + set errorMessage [testlistobj indexmemcheck 1] + testobj freeallvars + }] $errorMessage + } -result {0 {}} + + test memcheck-lindex-repeatedList { + Tcl_ListObjIndex memory leaks for lists of type repeatedList + } -constraints {testobj} -body { + list [{*}$memcheckcmd { + testobj set 1 [lrepeat $largeListLength [testobj new 2]] + set errorMessage [testlistobj indexmemcheck 1] + testobj freeallvars + }] $errorMessage + } -result {0 {}} + + test memcheck-lindex-reversedList { + Tcl_ListObjIndex memory leaks for reversedList lists + } -constraints {testobj} -body { + list [{*}$memcheckcmd { + testobj set 1 [lreverse [testlistrep new 1000]] + assertListType [testobj duplicate 1 2] reversedList + set errorMessage [testlistobj indexmemcheck 1] + testobj freeallvars + }] $errorMessage + } -result {0 {}} + + test memcheck-lindex-rangeList { + Tcl_ListObjIndex memory leaks for rangeList lists + } -constraints {testobj} -body { + list [{*}$memcheckcmd { + testobj set 1 [lrange \ + [lrepeat $largeListLength [testobj new 2]] \ + 1 end-1] + assertListType [testobj duplicate 1 2] rangeList + set errorMessage [testlistobj indexmemcheck 1] + testobj freeallvars + }] $errorMessage + } -result {0 {}} + + ## Test Tcl_ListObjGetElements does not leak memory + + test memcheck-getelements-list { + Tcl_ListObjElements memory leaks for native lists + } -constraints {testobj} -body { + list [{*}$memcheckcmd { + testobj set 1 [testlistrep new 1000] + assertListType [testobj duplicate 1 2] list + set errorMessage [testlistobj getelementsmemcheck 1] + testobj freeallvars + }] $errorMessage + } -result {0 {}} + + test memcheck-getelements-spanlist { + Tcl_ListObjElements memory leaks for native lists + } -constraints {testobj} -body { + list [{*}$memcheckcmd { + testobj set 1 [testlistrep new 1000 10 10] + assertListType [testobj duplicate 1 2] spanlist + set errorMessage [testlistobj getelementsmemcheck 1] + testobj freeallvars + }] $errorMessage + } -result {0 {}} + + test memcheck-getelements-arithseries { + Tcl_ListObjElements memory leaks for lseq + } -constraints {testobj} -body { + list [{*}$memcheckcmd { + testobj set 1 [lseq 1000] + set errorMessage [testlistobj getelementsmemcheck 1] + testobj freeallvars + }] $errorMessage + } -result {0 {}} + + test memcheck-getelements-repeatedList { + Tcl_ListObjElements memory leaks for lists of type repeatedList + } -constraints {testobj} -body { + list [{*}$memcheckcmd { + testobj set 1 [lrepeat $largeListLength [testobj new 2]] + set errorMessage [testlistobj getelementsmemcheck 1] + testobj freeallvars + }] $errorMessage + } -result {0 {}} + + test memcheck-getelements-reversedList { + Tcl_ListObjElements memory leaks for reversedList lists + } -constraints {testobj} -body { + list [{*}$memcheckcmd { + testobj set 1 [lreverse [testlistrep new 1000]] + assertListType [testobj duplicate 1 2] reversedList + set errorMessage [testlistobj getelementsmemcheck 1] + testobj freeallvars + }] $errorMessage + } -result {0 {}} + + test memcheck-getelements-rangeList { + Tcl_ListObjElements memory leaks for rangeList lists + } -constraints {testobj} -body { + list [{*}$memcheckcmd { + testobj set 1 [lrange \ + [lrepeat $largeListLength [testobj new 2]] \ + 1 end-1] + assertListType [testobj duplicate 1 2] rangeList + set errorMessage [testlistobj getelementsmemcheck 1] + testobj freeallvars + }] $errorMessage + } -result {0 {}} + + ## Test Tcl_ListObjReverse does not leak memory + foreach ltype $listTypes { + foreach nrefs {0 1 2} { + test memcheck-reverse-$ltype-nrefs$nrefs \ + "Tcl_ListObjReverse memory leaks for $ltype lists" \ + -constraints {testobj} \ + -body { + {*}$memcheckcmd { + testlistapi Tcl_ListObjReverse $nrefs [makeList $ltype] + } + } -result 0 + } + } + + ## Test Tcl_ListObjRange does not leak memory + foreach ltype $listTypes { + foreach nrefs {0 1 2} { + test memcheck-range-$ltype-nrefs$nrefs \ + "Tcl_ListObjRange memory leaks for $ltype lists" \ + -constraints {testobj} \ + -body { + {*}$memcheckcmd { + testlistapi Tcl_ListObjRange $nrefs [makeList $ltype] \ + 1 [expr {$largeListLength-2}] + } + } -result 0 + } + } + + ## Test Tcl_ListObjRepeat does not leak memory + foreach ltype $listTypes { + foreach repeatCount [list 0 $largeListLength] { + test memcheck-repeat-$ltype-count$repeatCount \ + "Tcl_ListObjRepeat memory leaks for $ltype lists" \ + -constraints {testobj} \ + -body { + {*}$memcheckcmd { + testlistapi Tcl_ListObjRepeat $repeatCount x y + } + } -result 0 + } + } +} + +# All done +::tcltest::cleanupTests diff --git a/tests/lpop.test b/tests/lpop.test index e5dfbbe..c1c4cbc 100644 --- a/tests/lpop.test +++ b/tests/lpop.test @@ -17,80 +17,166 @@ if {"::tcltest" ni [namespace children]} { } unset -nocomplain no; # following tests expecting var "no" does not exists -test lpop-1.1 {error conditions} -returnCodes error -body { +test lpop-1.1 {interpreted: error conditions} -returnCodes error -body { lpop no } -result {can't read "no": no such variable} -test lpop-1.2 {error conditions} -returnCodes error -body { +test lpop-1.2 {interpreted: error conditions} -returnCodes error -body { lpop no 0 } -result {can't read "no": no such variable} -test lpop-1.3 {error conditions} -returnCodes error -body { +test lpop-1.3 {interpreted: error conditions} -returnCodes error -body { set l "x {}x" lpop l } -result {list element in braces followed by "x" instead of space} -test lpop-1.4 {error conditions} -returnCodes error -body { +test lpop-1.4 {interpreted: error conditions} -returnCodes error -body { set l "x y" lpop l -1 } -result {index "-1" out of range} -test lpop-1.4b {error conditions (also check SF on empty list variable, bug [234d6c811d])} -body { +test lpop-1.4b {interpreted: error conditions (also check SF on empty list variable, bug [234d6c811d])} -body { set l "x y" list [lpop l] [lpop l] [catch {lpop l} v] $v [catch {lpop l 0} v] $v $l } -result {y x 1 {index "end" out of range} 1 {index "0" out of range} {}} -test lpop-1.5 {error conditions} -returnCodes error -body { +test lpop-1.5 {interpreted: error conditions} -returnCodes error -body { set l "x y z" lpop l 3 } -result {index "3" out of range} ;#-errorCode {TCL OPERATION LPOP BADINDEX} -test lpop-1.6 {error conditions} -returnCodes error -body { +test lpop-1.6 {interpreted: error conditions} -returnCodes error -body { set l "x y" lpop l end+1 } -result {index "end+1" out of range} -test lpop-1.7 {error conditions} -returnCodes error -body { +test lpop-1.7 {interpreted: error conditions} -returnCodes error -body { set l "x y" lpop l {} } -match glob -result {bad index *} -test lpop-1.8 {error conditions} -returnCodes error -body { +test lpop-1.8 {interpreted: error conditions} -returnCodes error -body { set l "x y" lpop l 0 0 0 0 1 } -result {index "1" out of range} -test lpop-1.9 {error conditions} -returnCodes error -body { +test lpop-1.9 {interpreted: error conditions} -returnCodes error -body { set l "x y" lpop l {1 0} } -match glob -result {bad index *} -test lpop-2.1 {basic functionality} -body { +test lpop-2.1 {interpreted: basic functionality} -body { set l "x y z" list [lpop l 0] $l } -result {x {y z}} -test lpop-2.2 {basic functionality} -body { +test lpop-2.2 {interpreted: basic functionality} -body { set l "x y z" list [lpop l 1] $l } -result {y {x z}} -test lpop-2.3 {basic functionality} -body { +test lpop-2.3 {interpreted: basic functionality} -body { set l "x y z" list [lpop l] $l } -result {z {x y}} -test lpop-2.4 {basic functionality} -body { +test lpop-2.4 {interpreted: basic functionality} -body { set l "x y z" set l2 $l list [lpop l] $l $l2 } -result {z {x y} {x y z}} -test lpop-3.1 {nested} -body { +test lpop-3.1 {interpreted: nested} -body { set l "x y" set l2 $l list [lpop l 0 0 0 0] $l $l2 } -result {x {{{{}}} y} {x y}} -test lpop-3.2 {nested} -body { +test lpop-3.2 {interpreted: nested} -body { set l "{x y} {a b}" list [lpop l 0 1] $l } -result {y {x {a b}}} -test lpop-3.3 {nested} -body { +test lpop-3.3 {interpreted: nested} -body { set l "{x y} {a b}" list [lpop l 1 0] $l } -result {a {{x y} b}} +test lpop-4.1 {compiled: error conditions} -returnCodes error -body { + apply {"" { + lpop no + }} +} -result {can't read "no": no such variable} +test lpop-4.2 {compiled: error conditions} -returnCodes error -body { + apply {"" { + lpop no 0 + }} +} -result {can't read "no": no such variable} +test lpop-4.3 {compiled: error conditions} -returnCodes error -body { + apply {l { + lpop l + }} "x {}x" +} -result {list element in braces followed by "x" instead of space} +test lpop-4.4 {compiled: error conditions} -returnCodes error -body { + apply {l { + lpop l -1 + }} "x y" +} -result {index "-1" out of range} +test lpop-4.4b {compiled: error conditions (also check SF on empty list variable, bug [234d6c811d])} -body { + apply {l { + list [lpop l] [lpop l] [catch {lpop l} v] $v [catch {lpop l 0} v] $v $l + }} "x y" +} -result {y x 1 {index "end" out of range} 1 {index "0" out of range} {}} +test lpop-4.5 {compiled: error conditions} -returnCodes error -body { + apply {l { + lpop l 3 + }} "x y z" +} -result {index "3" out of range} ;#-errorCode {TCL OPERATION LPOP BADINDEX} +test lpop-4.6 {compiled: error conditions} -returnCodes error -body { + apply {l { + lpop l end+1 + }} "x y" +} -result {index "end+1" out of range} +test lpop-4.7 {compiled: error conditions} -returnCodes error -body { + apply {l { + lpop l {} + }} "x y" +} -match glob -result {bad index *} +test lpop-4.8 {compiled: error conditions} -returnCodes error -body { + apply {l { + lpop l 0 0 0 0 1 + }} "x y" +} -result {index "1" out of range} +test lpop-4.9 {compiled: error conditions} -returnCodes error -body { + apply {l { + lpop l {1 0} + }} "x y" +} -match glob -result {bad index *} +test lpop-5.1 {compiled: basic functionality} -body { + apply {l { + list [lpop l 0] $l + }} "x y z" +} -result {x {y z}} +test lpop-5.2 {compiled: basic functionality} -body { + apply {l { + list [lpop l 1] $l + }} "x y z" +} -result {y {x z}} +test lpop-5.3 {compiled: basic functionality} -body { + apply {l { + list [lpop l] $l + }} "x y z" +} -result {z {x y}} +test lpop-5.4 {compiled: basic functionality} -body { + apply {l { + set l2 $l + list [lpop l] $l $l2 + }} "x y z" +} -result {z {x y} {x y z}} - +test lpop-6.1 {compiled: nested} -body { + apply {l { + set l2 $l + list [lpop l 0 0 0 0] $l $l2 + }} "x y" +} -result {x {{{{}}} y} {x y}} +test lpop-6.2 {compiled: nested} -body { + apply {l { + list [lpop l 0 1] $l + }} "{x y} {a b}" +} -result {y {x {a b}}} +test lpop-6.3 {compiled: nested} -body { + apply {l { + list [lpop l 1 0] $l + }} "{x y} {a b}" +} -result {a {{x y} b}} test lpop-99.1 {performance} -constraints perf -body { set l [lrepeat 10000 x] @@ -135,6 +221,53 @@ test lpop-99.2 {performance} -constraints perf -body { expr {$ratio > 10 ? $ratio : 10} } -result {10} +test lpop-99.3 {compiled: performance} -constraints perf -body { + set ratio [apply {"" { + set l [lrepeat 10000 x] + set l2 $l + set t1 [time { + while {[llength $l] >= 2} { + lpop l end + } + }] + set l [lrepeat 30000 x] + set l2 $l + set t2 [time { + while {[llength $l] >= 2} { + lpop l end + } + }] + regexp {\d+} $t1 ms1 + regexp {\d+} $t2 ms2 + expr {double($ms2)/$ms1} + }}] + # Deleting from end should have linear performance + expr {$ratio > 4 ? $ratio : 4} +} -result {4} + +test lpop-99.4 {compiled: performance} -constraints perf -body { + set ratio [apply {"" { + set l [lrepeat 10000 x] + set l2 $l + set t1 [time { + while {[llength $l] >= 2} { + lpop l 1 + } + }] + set l [lrepeat 30000 x] + set l2 $l + set t2 [time { + while {[llength $l] >= 2} { + lpop l 1 + } + }] + regexp {\d+} $t1 ms1 + regexp {\d+} $t2 ms2 + expr {double($ms2)/$ms1} + }}] + expr {$ratio > 10 ? $ratio : 10} +} -result {10} + # cleanup ::tcltest::cleanupTests diff --git a/tests/lrange.test b/tests/lrange.test index 0448b9c..566cf61 100644 --- a/tests/lrange.test +++ b/tests/lrange.test @@ -186,11 +186,9 @@ test lrange-4.3 {lrange pure promise} -body { # Get pure object, unshared set ll2 [lrange $ll1[set ll1 {}] 0 end] set rep2 [tcl::unsupported::representation $ll2] - regexp {object pointer at (\S+)} $rep1 -> obj1 - regexp {object pointer at (\S+)} $rep2 -> obj2 - list $rep1 $rep2 [string equal $obj1 $obj2] + list $rep1 $rep2 # Internal optimisations should keep the same object -} -match glob -result {*value is *refcount of 2,*, string rep*value is*refcount of 2,* no string rep* 1} +} -match glob -result {*value is *refcount of 2,*, string rep*value is*refcount of 2,* no string rep*} test lrange-4.4 {lrange pure promise} -body { set ll1 [list $tcl_version 2 3 4] @@ -200,11 +198,9 @@ test lrange-4.4 {lrange pure promise} -body { # Get pure object, unshared, not compiled set ll2 [[string cat l range] $ll1[set ll1 {}] 0 end] set rep2 [tcl::unsupported::representation $ll2] - regexp {object pointer at (\S+)} $rep1 -> obj1 - regexp {object pointer at (\S+)} $rep2 -> obj2 - list $rep1 $rep2 [string equal $obj1 $obj2] + list $rep1 $rep2 # Internal optimisations should keep the same object -} -match glob -result {*value is *refcount of 2,*, string rep*value is*refcount of 2,* no string rep* 1} +} -match glob -result {*value is *refcount of 2,*, string rep*value is*refcount of 2,* no string rep*} # Testing for compiled vs non-compiled behaviour, and shared vs non-shared. # Far too many variations to check with spelt-out tests. diff --git a/tests/lseq.test b/tests/lseq.test index 4e6626c..4117dae 100644 --- a/tests/lseq.test +++ b/tests/lseq.test @@ -19,6 +19,8 @@ testConstraint arithSeriesShimmer 1 testConstraint arithSeriesShimmerOk 1 testConstraint has64BitLengths [expr {$tcl_platform(pointerSize) == 8}] testConstraint has32BitLengths [expr {$tcl_platform(pointerSize) == 4}] +testConstraint exec [llength [info commands exec]] +testConstraint memory [llength [info commands memory]] proc memusage {} { set fd [open /proc/[pid]/statm] @@ -30,6 +32,16 @@ proc memusage {} { return [lindex $line 5] } testConstraint hasMemUsage [expr {![catch {memusage}]}] +testConstraint notPurify [expr {![tcl::build-info purify]}] +proc leaktest {script {iterations 3}} { + set end [lindex [split [memory info] \n] 3 3] + for {set i 0} {$i < $iterations} {incr i} { + uplevel 1 $script + set tmp $end + set end [lindex [split [memory info] \n] 3 3] + } + return [expr {$end - $tmp}] +} # Arg errors test lseq-1.1 {error cases} -body { @@ -1025,15 +1037,67 @@ test lseq-convertToList {does not result in a memory error} -body { } -cleanup {unset var1 cres} -result {1 {can't set "var1": this is an error}} test lseq-bug-54329e39c7 {does not cause memory bloat} -constraints { - hasMemUsage + nonPortable hasMemUsage notPurify } -body { - set l [lseq 1000000] proc p l {foreach x $l {}} + p {1 2} + set l [lseq 1000000] set premem [memusage] p $l set postmem [memusage] - expr {[tcl::build-info purify] || ($postmem - $premem < 10) ? 1 : ($postmem - $premem)} -} -result 1 + expr {abs($postmem - $premem) < 10 ? "ok" : ($postmem - $premem)} +} -cleanup { + rename p {} + unset -nocomplain l +} -result ok +test lseq-bug-54329e39c7-bis {does not cause memory bloat} -constraints { + exec memory +} -body { + exec [interpreter] << { + # No change to PEAK memory usage in a fresh interpreter + proc memtest script { + set start [lindex [split [memory info] \n] 5 end] + uplevel 1 $script + set end [lindex [split [memory info] \n] 5 end] + expr {$end - $start} + } + proc p l {foreach x $l {}} + p {1 2} + puts [memtest { + set l [lseq 1000000] + p $l + }] + } +} -result 0 + +test lseq-comp-1.1 {compiled lseq memory leaks: numbers} -constraints memory -body { + leaktest {lseq 123} +} -result 0 +test lseq-comp-1.2 {compiled lseq memory leak: numbers} -constraints memory -body { + leaktest {lseq 123.0} +} -result 0 +test lseq-comp-1.3 {compiled lseq memory leak: numbers} -constraints memory -body { + leaktest {lseq 1 3} +} -result 0 +test lseq-comp-1.4 {compiled lseq memory leak: numbers} -constraints memory -body { + leaktest {lseq 1 5 3} +} -result 0 +test lseq-comp-1.5 {compiled lseq memory leak: numbers} -constraints memory -body { + leaktest {lseq 1.0 5.4 .3} +} -result 0 + +test lseq-comp-2.1 {compiled lseq memory leak: expressions} -constraints memory -body { + set x 123 + leaktest {lseq {$x - 2} .. {$x + 2}} +} -result 0 +test lseq-comp-2.2 {compiled lseq memory leak: expressions} -constraints memory -body { + set x 123 + leaktest {lseq {$x} .. {$x + 2} by {$x - 17}} +} -result 0 +test lseq-comp-2.3 {compiled lseq memory leak: expressions} -constraints memory -body { + set x 123 + leaktest {lseq {$x} count {$x + 2} by {$x - 17}} +} -result 0 test lseq-bug-578b7e273c03-1 {Arithmetic Series Objects get wrong precision when end value is not specified} -body { set bl [expr {2.8 in [lseq 0 count 100 by .1]}] @@ -1053,7 +1117,7 @@ test lseq-bug-578b7e273c03-2 {Arithmetic Series Objects get wrong precision when lappend ll [llength [lseq 0 count 200 by .011]] } -result {100 200 100 200 100 200} -test lseq-bug-f4a4bd7f1070-1 {} -body { +test lseq-bug-f4a4bd7f1070-1 {semantics of count parameter} -body { set result {} lappend result [catch {lseq 3.1} msg] lappend result $msg diff --git a/tests/nre.test b/tests/nre.test index 357f120..0fd988c 100644 --- a/tests/nre.test +++ b/tests/nre.test @@ -35,10 +35,7 @@ if {[testConstraint testnrelevels]} { proc depthDiff {} { variable last set depth [testnrelevels] - set res {} - foreach t $depth l $last { - lappend res [expr {$t-$l}] - } + set res [lmap t $depth l $last {expr {$t - $l}}] set last $depth return $res } @@ -223,6 +220,16 @@ test nre-6.2 {[uplevel] is not recursive} -setup { } -constraints { testnrelevels } -result {{0 2 2 0} 0} +test nre-6.3 {[uplevel] is not recursive} -setup { + proc a i [makebody {uplevel [list a $i]}] +} -body { + setabs + a 0 +} -cleanup { + rename a {} +} -constraints { + testnrelevels +} -result {{0 2 2 0} 0} test nre-7.1 {[catch] is not recursive} -setup { setabs diff --git a/tests/oo.test b/tests/oo.test index 21c8f9e..7d5ea37 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -390,7 +390,7 @@ test oo-1.21 {basic test of OO functionality: default relations} -setup { }] {lsort [lsearch -all -not -inline $x *::delegate]} } -cleanup { interp delete $fresh -} -result {{} {::oo::Slot ::oo::abstract ::oo::class ::oo::configurable ::oo::configuresupport::configurable ::oo::object ::oo::singleton} {::oo::configuresupport::objreadableproperties ::oo::configuresupport::objwritableproperties ::oo::configuresupport::readableproperties ::oo::configuresupport::writableproperties ::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable} {::oo::Slot ::oo::class ::oo::configuresupport::configurable} {::oo::abstract ::oo::configurable ::oo::singleton} {} {} {} {} {} ::oo::object ::oo::object ::oo::class ::oo::class ::oo::class} +} -result {{} {::oo::SingletonInstance ::oo::Slot ::oo::abstract ::oo::class ::oo::configurable ::oo::configuresupport::configurable ::oo::object ::oo::singleton} {::oo::configuresupport::objreadableproperties ::oo::configuresupport::objwritableproperties ::oo::configuresupport::readableproperties ::oo::configuresupport::writableproperties ::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable} {::oo::SingletonInstance ::oo::Slot ::oo::class ::oo::configuresupport::configurable} {::oo::abstract ::oo::configurable ::oo::singleton} {} {} {} {} {} ::oo::object ::oo::object ::oo::class ::oo::class ::oo::class} test oo-1.22 {basic test of OO functionality: nested ownership destruction order} -setup { oo::class create parent } -body { diff --git a/tests/ooUtil.test b/tests/ooUtil.test index 5a8a25b..74ffa8e 100644 --- a/tests/ooUtil.test +++ b/tests/ooUtil.test @@ -115,7 +115,7 @@ test ooUtil-1.6 {TIP 478: classmethod and instances} -setup { } -returnCodes error -cleanup { parent destroy } -match glob -result {unknown method "find": must be *} -test ooUtil-1.7 {} -setup { +test ooUtil-1.7 {classmethod and subclasses} -setup { oo::class create parent } -body { oo::class create Foo { diff --git a/tests/reg.test b/tests/reg.test index 471adba..3ca97bc 100644 --- a/tests/reg.test +++ b/tests/reg.test @@ -1195,25 +1195,25 @@ test reg-33.22 {constraint fixes} { regexp {(^(?!aa)(?!bb)(?!cc))+} {dd x} } 1 -test reg-33.23 {} { +test reg-33.23 {constraint edge cases} { regexp {abcd(\m)+xyz} x } 0 -test reg-33.24 {} { +test reg-33.24 {constraint edge cases} { regexp {abcd(\m)+xyz} a } 0 -test reg-33.25 {} { +test reg-33.25 {constraint edge cases} { regexp {^abcd*(((((^(a c(e?d)a+|)+|)+|)+|)+|a)+|)} x } 0 -test reg-33.26 {} { +test reg-33.26 {constraint edge cases} { regexp {a^(^)bcd*xy(((((($a+|)+|)+|)+$|)+|)+|)^$} x } 0 -test reg-33.27 {} { +test reg-33.27 {constraint edge cases} { regexp {xyz(\Y\Y)+} x } 0 -test reg-33.28 {} { +test reg-33.28 {constraint edge cases} { regexp {x|(?:\M)+} x } 1 -test reg-33.29 {} { +test reg-33.29 {constraint edge cases} { # This is near the limits of the RE engine regexp [string repeat x*y*z* 480] x } 1 diff --git a/tests/registry.test b/tests/registry.test index e20c945..54c7122 100644 --- a/tests/registry.test +++ b/tests/registry.test @@ -19,7 +19,7 @@ testConstraint reg 0 if {[testConstraint win]} { if {![catch { ::tcltest::loadTestedCommands - set ::regver [package require registry 1.3.7] + set ::regver [package require registry 1.4a1] }]} { testConstraint reg 1 } @@ -34,7 +34,7 @@ testConstraint english [expr { test registry-1.0 {check if we are testing the right dll} {win reg} { set ::regver -} {1.3.7} +} {1.4a1} test registry-1.1 {argument parsing for registry command} {win reg} { list [catch {registry} msg] $msg } {1 {wrong # args: should be "registry ?-32bit|-64bit? option ?arg ...?"}} diff --git a/tests/socket.test b/tests/socket.test index 82b3636..08c7793 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -701,7 +701,7 @@ test socket_$af-2.11 {detecting new data} -constraints [list socket supported_$a close $s close $sock } -result {a:one b: c:two} -test socket_$af-2.12 {} [list socket stdio supported_$af] { +test socket_$af-2.12 {Bug 1758a0b603?} [list socket stdio supported_$af] { file delete $path(script) set f [open $path(script) w] puts $f { diff --git a/tests/split.test b/tests/split.test index 6c90419..259a35d 100644 --- a/tests/split.test +++ b/tests/split.test @@ -83,7 +83,6 @@ test split-2.1 {split errors} { test split-2.2 {split errors} { list [catch {split a b c} msg] $msg $errorCode } {1 {wrong # args: should be "split string ?splitChars?"} {TCL WRONGARGS}} - # cleanup catch {rename foo {}} diff --git a/tests/string.test b/tests/string.test index 5c06068..6754508 100644 --- a/tests/string.test +++ b/tests/string.test @@ -226,7 +226,11 @@ test string-2.36.$noComp {string compare, binary neq unequal length} { run {string compare [binary format a20a 0 1] [binary format a100a 0 0]} } 1 test string-2.37.$noComp {string compare, big -length} { - run {string compare -length 0x100000000 ab abde} + if {[package vsatisfies [info patchlevel] 8.7-]} { + run {string compare -length 0x100000000 ab abde} + } else { + run {string compare -length 0x7fffffff ab abde} + } } -1 test string-2.38a.$noComp {string compare empty string against byte array} { # Bug edb4b065f4 @@ -393,7 +397,11 @@ test string-3.42.$noComp {string equal, binary neq inequal length} { run {string equal [binary format a20a 0 1] [binary format a100a 0 0]} } 0 test string-3.43.$noComp {string equal, big -length} { - run {string equal -length 0x100000000 abc def} + if {[package vsatisfies [info patchlevel] 8.7-]} { + run {string equal -length 0x100000000 abc def} + } else { + run {string equal -length 0x7fffffff abc def} + } } 0 test string-3.44.$noComp {string equal, bigger -length} -body { run {string equal -length 18446744073709551616 abc def} @@ -1718,10 +1726,10 @@ test stringComp-14.24.$noComp {Bug 1af8de570511} { string replace $val[unset val] 1 1 $y }} 4 x } 0x00 -test stringComp-14.25.$noComp {} { +test stringComp-14.25.$noComp {repeated unicode} { string length [string replace [string repeat a\xFE 2] 3 end {}] } 3 -test stringComp-14.26.$noComp {} { +test stringComp-14.26.$noComp {expression indices} { run {string replace abcd 0x10000000000000000-0xffffffffffffffff 2 e} } aed diff --git a/tests/stringObj.test b/tests/stringObj.test index 4c78d82..fb7e796 100644 --- a/tests/stringObj.test +++ b/tests/stringObj.test @@ -21,6 +21,7 @@ if {"::tcltest" ni [namespace children]} { catch [list package require -exact tcl::test [info patchlevel]] testConstraint testobj [llength [info commands testobj]] +testConstraint testisempty [llength [info commands testisempty]] testConstraint testbytestring [llength [info commands testbytestring]] testConstraint testdstring [llength [info commands testdstring]] @@ -527,6 +528,26 @@ test stringObj-16.12 {Tcl_GetRange: first = last = SIZE_MAX-1} testobj { set i [expr {$SIZE_MAX - 1}] teststringobj range 1 $i $i } {} + +test stringObj-17.1 {Tcl_StringIsEmpty, handle list} testisempty { + set x "abc" + lappend x "def" + testisempty $x +} {0 pure list} +test stringObj-17.2 {Tcl_StringIsEmpty, handle empty list} testisempty { + set x "abc" + set x [lreplace x 0 end] + list $x {*}[testisempty $x] +} {{} 1 pure list} +test stringObj-17.3 {Tcl_StringIsEmpty, handle dict} testisempty { + set x "1 abc" + set x [dict set $x 2 "def"] + testisempty $x +} {0 pure dict} +test stringObj-17.4 {Tcl_StringIsEmpty, handle integer} testisempty { + testisempty [expr {3+4}] +} {0 pure int} + if {[testConstraint testobj]} { testobj freeallvars diff --git a/tests/subst.test b/tests/subst.test index da59c3b..30dba7d 100644 --- a/tests/subst.test +++ b/tests/subst.test @@ -22,10 +22,10 @@ testConstraint testbytestring [llength [info commands testbytestring]] test subst-1.1 {basics} -returnCodes error -body { subst -} -result {wrong # args: should be "subst ?-nobackslashes? ?-nocommands? ?-novariables? string"} +} -result {wrong # args: should be "subst ?-backslashes? ?-commands? ?-variables? ?-nobackslashes? ?-nocommands? ?-novariables? string"} test subst-1.2 {basics} -returnCodes error -body { subst a b c -} -result {bad option "a": must be -nobackslashes, -nocommands, or -novariables} +} -result {bad option "a": must be -backslashes, -commands, -variables, -nobackslashes, -nocommands, or -novariables} test subst-2.1 {simple strings} { subst {} @@ -123,13 +123,13 @@ test subst-6.1 {clear the result after command substitution} -body { test subst-7.1 {switches} -returnCodes error -body { subst foo bar -} -result {bad option "foo": must be -nobackslashes, -nocommands, or -novariables} +} -result {bad option "foo": must be -backslashes, -commands, -variables, -nobackslashes, -nocommands, or -novariables} test subst-7.2 {switches} -returnCodes error -body { subst -no bar -} -result {ambiguous option "-no": must be -nobackslashes, -nocommands, or -novariables} +} -result {ambiguous option "-no": must be -backslashes, -commands, -variables, -nobackslashes, -nocommands, or -novariables} test subst-7.3 {switches} -returnCodes error -body { subst -bogus bar -} -result {bad option "-bogus": must be -nobackslashes, -nocommands, or -novariables} +} -result {bad option "-bogus": must be -backslashes, -commands, -variables, -nobackslashes, -nocommands, or -novariables} test subst-7.4 {switches} { set x 123 subst -nobackslashes {abc $x [expr {1 + 2}] \\\x41} @@ -146,7 +146,38 @@ test subst-7.7 {switches} { set x 123 subst -nov -nob -noc {abc $x [expr {1 + 2}] \\\x41} } {abc $x [expr {1 + 2}] \\\x41} - +test subst-7.8 {positive switches} { + set x 123 + subst -backslashes {abc $x [expr {1 + 2}] \\\x41} +} {abc $x [expr {1 + 2}] \A} +test subst-7.9 {positive switches} { + set x 123 + subst -commands {abc $x [expr {1 + 2}] \\\x41} +} {abc $x 3 \\\x41} +test subst-7.10 {positive switches} { + set x 123 + subst -variables {abc $x [expr {1 + 2}] \\\x41} +} {abc 123 [expr {1 + 2}] \\\x41} +test subst-7.4.11 {positive switches} { + set x 123 + subst -commands -variables {abc $x [expr {1 + 2}] \\\x41} +} {abc 123 3 \\\x41} +test subst-7.12 {positive switches} { + set x 123 + subst -backslashes -variables {abc $x [expr {1 + 2}] \\\x41} +} {abc 123 [expr {1 + 2}] \A} +test subst-7.13 {positive switches} { + set x 123 + subst -backslashes -commands {abc $x [expr {1 + 2}] \\\x41} +} {abc $x 3 \A} +test subst-7.14 {positive switches} { + set x 123 + subst -ba -co -va {abc $x [expr {1 + 2}] \\\x41} +} {abc 123 3 \A} +test subst-7.15 {mixed switches} -returnCodes error -body { + set x 123 + subst -backslashes -novariables {abc $x [expr {1 + 2}] \\\x41} +} -result {cannot combine positive and negative options} test subst-8.1 {return in a subst} { subst {foo [return {x}; bogus code] bar} } {foo x bar} diff --git a/tests/tailcall.test b/tests/tailcall.test index 0016845..b373b9e 100644 --- a/tests/tailcall.test +++ b/tests/tailcall.test @@ -49,6 +49,24 @@ if {[testConstraint testnrelevels]} { proc errorcode options { dict get [dict merge {-errorcode NONE} $options] -errorcode } + +# Used for constraining memory leak tests +testConstraint memory [llength [info commands memory]] +if {[testConstraint memory]} { + proc getbytes {} { + set lines [split [memory info] \n] + return [lindex $lines 3 3] + } + proc leaktest {script {iterations 3}} { + set end [getbytes] + for {set i 0} {$i < $iterations} {incr i} { + uplevel 1 $script + set tmp $end + set end [getbytes] + } + return [expr {$end - $tmp}] + } +} test tailcall-0.1 {tailcall is constant space} -constraints testnrelevels -setup { proc a i { @@ -708,6 +726,58 @@ test tailcall-14.1-bc {{in a deleted namespace} {byte compiled}} -body { } } -returnCodes 1 -result {namespace "::ns" not found} +test tailcall-15.1 {tailcall memory leak check} -constraints memory -setup { + proc foo {args} {llength $args} +} -body { + list [ + apply {cmd { + $cmd foo 1 2 3 4 5 + }} tailcall + ] [ + leaktest { + apply {cmd { + $cmd foo 1 2 3 4 5 + }} tailcall + } + ] +} -cleanup { + rename foo {} +} -result {5 0} +test tailcall-15.2 {tailcall memory leak check} -constraints memory -setup { + proc foo {args} {llength $args} +} -body { + list [ + apply {{} { + tailcall foo 1 2 3 4 5 + }} + ] [ + leaktest { + apply {{} { + tailcall foo 1 2 3 4 5 + }} + } + ] +} -cleanup { + rename foo {} +} -result {5 0} +test tailcall-15.3 {tailcall memory leak check} -constraints memory -setup { + proc foo {args} {llength $args} +} -body { + list [ + apply {args { + tailcall foo 1 2 {*}$args 3 4 {*}$args 5 + }} a b c + ] [ + leaktest { + apply {args { + tailcall foo 1 2 {*}$args 3 4 {*}$args 5 + }} a b c + } + ] +} -cleanup { + rename foo {} +} -result {11 0} + test tailcall-bug-784befb0ba {tailcall crash with 254 args} -body { proc tccrash args {llength $args} # Must be EXACTLY 254 for crash diff --git a/tests/tcltests.tcl b/tests/tcltests.tcl index ccb77c3..5897022 100644 --- a/tests/tcltests.tcl +++ b/tests/tcltests.tcl @@ -28,6 +28,7 @@ testConstraint notValgrind [expr {![testConstraint valgrind]}] namespace eval ::tcltests { + variable TCL_SIZE_MAX [expr {(2**(8*$::tcl_platform(pointerSize)-1))-1}] proc init {} { if {[namespace which ::tcl::file::tempdir] eq {}} { @@ -135,6 +136,7 @@ namespace eval ::tcltests { return [windowscodepage] } } + } init diff --git a/tests/winDde.test b/tests/winDde.test index 038de62..ec821da 100644 --- a/tests/winDde.test +++ b/tests/winDde.test @@ -19,7 +19,7 @@ testConstraint dde 0 if {[testConstraint win]} { if {![catch { ::tcltest::loadTestedCommands - set ::ddever [package require dde 1.4.5] + set ::ddever [package require dde 1.5] set ::ddelib [info loaded {} Dde]}]} { testConstraint dde 1 } @@ -105,7 +105,7 @@ proc createChildProcess {ddeServerName args} { # ------------------------------------------------------------------------- test winDde-1.0 {check if we are testing the right dll} {win dde} { set ::ddever -} {1.4.5} +} {1.5a1} test winDde-1.1 {Settings the server's topic name} -constraints dde -body { list [dde servername foobar] [dde servername] [dde servername self] diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl index 66e125d..b17d7d0 100644 --- a/tools/tclOOScript.tcl +++ b/tools/tclOOScript.tcl @@ -14,33 +14,6 @@ ::namespace eval ::oo { # ---------------------------------------------------------------------- # - # Slot -- - # - # The class of slot operations, which are basically lists at the low - # level of TclOO; this provides a more consistent interface to them. - # - # ---------------------------------------------------------------------- - - # ------------------------------------------------------------------ - # - # Slot --default-operation -- - # - # If a slot can't figure out what method to call directly, it - # uses --default-operation. - # - # ------------------------------------------------------------------ - define Slot forward --default-operation my -append - - # Hide destroy - define Slot unexport destroy - - # Set the default operation differently for these slots - objdefine define::superclass forward --default-operation my -set - objdefine define::mixin forward --default-operation my -set - objdefine objdefine::mixin forward --default-operation my -set - - # ---------------------------------------------------------------------- - # # oo::object <cloned> -- # # Handler for cloning objects that clones basic bits (only!) of the @@ -119,27 +92,37 @@ class create singleton define singleton superclass -set class - define singleton variable -set object define singleton unexport create createWithNamespace define singleton method new args { + variable object if {![info exists object] || ![info object isa object $object]} { set object [next {*}$args] - ::oo::objdefine $object { - method destroy {} { - return -code error -errorcode {TCL OO SINGLETON} \ - "may not destroy a singleton object" - } - method <cloned> -unexport {originObject} { - return -code error -errorcode {TCL OO SINGLETON} \ - "may not clone a singleton object" - } - } + ::oo::objdefine $object mixin -prepend ::oo::SingletonInstance } return $object } # ---------------------------------------------------------------------- # + # oo::SingletonInstance -- + # + # A mixin used to make an object so it won't be destroyed or cloned (or + # at least not easily). + # + # ---------------------------------------------------------------------- + + class create SingletonInstance + define SingletonInstance method destroy {} { + return -code error -errorcode {TCL OO SINGLETON} \ + "may not destroy a singleton object" + } + define SingletonInstance method <cloned> -unexport {originObject} { + return -code error -errorcode {TCL OO SINGLETON} \ + "may not clone a singleton object" + } + + # ---------------------------------------------------------------------- + # # oo::abstract -- # # A metaclass that is used to make classes that can't be directly diff --git a/unix/Makefile.in b/unix/Makefile.in index 253d384..194f17c 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -309,7 +309,7 @@ GENERIC_OBJS = regcomp.o regexec.o regfree.o regerror.o tclAlloc.o \ tclHash.o tclHistory.o \ tclIcu.o tclIndexObj.o tclInterp.o tclIO.o tclIOCmd.o \ tclIORChan.o tclIORTrans.o tclIOGT.o tclIOSock.o tclIOUtil.o \ - tclLink.o tclListObj.o \ + tclLink.o tclListObj.o tclListTypes.o \ tclLiteral.o tclLoad.o tclMain.o tclNamesp.o tclNotify.o \ tclObj.o tclOptimize.o tclPanic.o tclParse.o tclPathObj.o tclPipe.o \ tclPkg.o tclPkgConfig.o tclPosixStr.o \ @@ -447,6 +447,7 @@ GENERIC_SRCS = \ $(GENERIC_DIR)/tclIORTrans.c \ $(GENERIC_DIR)/tclLink.c \ $(GENERIC_DIR)/tclListObj.c \ + $(GENERIC_DIR)/tclListTypes.c \ $(GENERIC_DIR)/tclLiteral.c \ $(GENERIC_DIR)/tclLoad.c \ $(GENERIC_DIR)/tclMain.c \ @@ -1419,6 +1420,9 @@ tclLink.o: $(GENERIC_DIR)/tclLink.c tclListObj.o: $(GENERIC_DIR)/tclListObj.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclListObj.c +tclListTypes.o: $(GENERIC_DIR)/tclListTypes.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclListTypes.c + tclLiteral.o: $(GENERIC_DIR)/tclLiteral.c $(COMPILEHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclLiteral.c @@ -2041,7 +2045,6 @@ PKG_CFG_ARGS = @PKG_CFG_ARGS@ # cannot use absolute paths due to issues in nested configure when path to # build dir contains spaces). PKG_DIR = ./pkgs -PKG8_DIR = ./pkgs8 configure-packages: @for i in $(PKGS_DIR)/*; do \ @@ -2049,14 +2052,6 @@ configure-packages: if [ -x $$i/configure ] ; then \ pkg=`basename $$i`; \ echo "Configuring package '$$pkg'"; \ - mkdir -p $(PKG8_DIR)/$$pkg; \ - if [ ! -f $(PKG8_DIR)/$$pkg/Makefile ] ; then \ - ( cd $(PKG8_DIR)/$$pkg; \ - $$i/configure --with-tcl8 --with-tcl=../.. \ - --with-tclinclude=$(GENERIC_DIR) \ - $(PKG_CFG_ARGS) --libdir=$(PACKAGE_DIR) \ - --enable-shared; ) || exit $$?; \ - fi; \ mkdir -p $(PKG_DIR)/$$pkg; \ if [ ! -f $(PKG_DIR)/$$pkg/Makefile ] ; then \ ( cd $(PKG_DIR)/$$pkg; \ @@ -2073,10 +2068,6 @@ packages: configure-packages ${STUB_LIB_FILE} @for i in $(PKGS_DIR)/*; do \ if [ -d $$i ] ; then \ pkg=`basename $$i`; \ - if [ -f $(PKG8_DIR)/$$pkg/Makefile ] ; then \ - echo "Building package '$$pkg' for Tcl 8"; \ - ( cd $(PKG8_DIR)/$$pkg; $(MAKE); ) || exit $$?; \ - fi; \ if [ -f $(PKG_DIR)/$$pkg/Makefile ] ; then \ echo "Building package '$$pkg'"; \ ( cd $(PKG_DIR)/$$pkg; $(MAKE); ) || exit $$?; \ @@ -2088,11 +2079,6 @@ install-packages: packages @for i in $(PKGS_DIR)/*; do \ if [ -d $$i ] ; then \ pkg=`basename $$i`; \ - if [ -f $(PKG8_DIR)/$$pkg/Makefile ] ; then \ - echo "Installing package '$$pkg' for Tcl 8"; \ - ( cd $(PKG8_DIR)/$$pkg; $(MAKE) install \ - "DESTDIR=$(INSTALL_ROOT)"; ) || exit $$?; \ - fi; \ if [ -f $(PKG_DIR)/$$pkg/Makefile ] ; then \ echo "Installing package '$$pkg'"; \ ( cd $(PKG_DIR)/$$pkg; $(MAKE) install \ @@ -2120,9 +2106,6 @@ clean-packages: @for i in $(PKGS_DIR)/*; do \ if [ -d $$i ] ; then \ pkg=`basename $$i`; \ - if [ -f $(PKG8_DIR)/$$pkg/Makefile ] ; then \ - ( cd $(PKG8_DIR)/$$pkg; $(MAKE) clean; ) \ - fi; \ if [ -f $(PKG_DIR)/$$pkg/Makefile ] ; then \ ( cd $(PKG_DIR)/$$pkg; $(MAKE) clean; ) \ fi; \ @@ -2133,17 +2116,12 @@ distclean-packages: @for i in $(PKGS_DIR)/*; do \ if [ -d $$i ] ; then \ pkg=`basename $$i`; \ - if [ -f $(PKG8_DIR)/$$pkg/Makefile ] ; then \ - ( cd $(PKG8_DIR)/$$pkg; $(MAKE) distclean; ) \ - fi; \ - rm -rf $(PKG8_DIR)/$$pkg; \ if [ -f $(PKG_DIR)/$$pkg/Makefile ] ; then \ ( cd $(PKG_DIR)/$$pkg; $(MAKE) distclean; ) \ fi; \ rm -rf $(PKG_DIR)/$$pkg; \ fi; \ done; \ - rm -rf $(PKG8_DIR) rm -rf $(PKG_DIR) dist-packages: configure-packages @@ -2313,11 +2291,10 @@ BUILTIN_PACKAGE_LIST = cookiejar http opt msgcat registry dde tcltest platform $(UNIX_DIR)/configure: $(UNIX_DIR)/configure.ac $(UNIX_DIR)/tcl.m4 \ $(UNIX_DIR)/aclocal.m4 - cd $(UNIX_DIR); autoconf -$(MAC_OSX_DIR)/configure: $(MAC_OSX_DIR)/configure.ac $(UNIX_DIR)/configure - cd $(MAC_OSX_DIR); autoconf -$(UNIX_DIR)/tclConfig.h.in: $(MAC_OSX_DIR)/configure - cd $(MAC_OSX_DIR); autoheader; touch $@ + @cd $(UNIX_DIR); autoconf || \ + echo "WARNING: Unable to rebuild $(UNIX_DIR)/configure. Please upgrade autoconf." +$(UNIX_DIR)/tclConfig.h.in: $(MAC_OSX_DIR)/configure.ac + @cd $(MAC_OSX_DIR); autoheader || touch $@ tclUuid.h: $(TOP_DIR)/manifest.uuid echo "#define TCL_VERSION_UUID \\" >$@ @@ -2332,7 +2309,7 @@ $(TOP_DIR)/manifest.uuid: printf "unknown" >$(TOP_DIR)/manifest.uuid) dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in genstubs \ - $(MAC_OSX_DIR)/configure $(TOP_DIR)/manifest.uuid dist-packages ${NATIVE_TCLSH} + $(TOP_DIR)/manifest.uuid dist-packages ${NATIVE_TCLSH} rm -rf $(DISTDIR) $(INSTALL_DATA_DIR) $(DISTDIR)/unix $(DIST_INSTALL_DATA) $(TOP_DIR)/manifest.uuid $(DISTDIR) @@ -2438,7 +2415,6 @@ dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in gen $(MAC_OSX_DIR)/*.c $(MAC_OSX_DIR)/*.in \ $(MAC_OSX_DIR)/*.ac \ $(DISTDIR)/macosx - $(DIST_INSTALL_SCRIPT) $(MAC_OSX_DIR)/configure $(DISTDIR)/macosx $(DIST_INSTALL_DATA) $(TOP_DIR)/license.terms $(DISTDIR)/macosx $(INSTALL_DATA_DIR) $(DISTDIR)/unix/dltest $(DIST_INSTALL_DATA) $(UNIX_DIR)/dltest/*.c $(UNIX_DIR)/dltest/Makefile.in \ diff --git a/unix/configure b/unix/configure index 4d96bdc..1c8be19 100755 --- a/unix/configure +++ b/unix/configure @@ -1,6 +1,6 @@ #! /bin/sh # Guess values for system-dependent variables and create Makefiles. -# Generated by GNU Autoconf 2.72 for tcl 9.0. +# Generated by GNU Autoconf 2.72 for tcl 9.1. # # # Copyright (C) 1992-1996, 1998-2017, 2020-2023 Free Software Foundation, @@ -601,8 +601,8 @@ MAKEFLAGS= # Identity of this package. PACKAGE_NAME='tcl' PACKAGE_TARNAME='tcl' -PACKAGE_VERSION='9.0' -PACKAGE_STRING='tcl 9.0' +PACKAGE_VERSION='9.1' +PACKAGE_STRING='tcl 9.1' PACKAGE_BUGREPORT='' PACKAGE_URL='' @@ -1366,7 +1366,7 @@ if test "$ac_init_help" = "long"; then # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF -'configure' configures tcl 9.0 to adapt to many kinds of systems. +'configure' configures tcl 9.1 to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... @@ -1428,7 +1428,7 @@ fi if test -n "$ac_init_help"; then case $ac_init_help in - short | recursive ) echo "Configuration of tcl 9.0:";; + short | recursive ) echo "Configuration of tcl 9.1:";; esac cat <<\_ACEOF @@ -1545,7 +1545,7 @@ fi test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then cat <<\_ACEOF -tcl configure 9.0 +tcl configure 9.1 generated by GNU Autoconf 2.72 Copyright (C) 2023 Free Software Foundation, Inc. @@ -2028,7 +2028,7 @@ cat >config.log <<_ACEOF This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. -It was created by tcl $as_me 9.0, which was +It was created by tcl $as_me 9.1, which was generated by GNU Autoconf 2.72. Invocation command line was $ $0$ac_configure_args_raw @@ -2707,10 +2707,10 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu -TCL_VERSION=9.0 +TCL_VERSION=9.1 TCL_MAJOR_VERSION=9 -TCL_MINOR_VERSION=0 -TCL_PATCH_LEVEL=".3" +TCL_MINOR_VERSION=1 +TCL_PATCH_LEVEL="a1" VERSION=${TCL_VERSION} EXTRA_INSTALL_BINARIES=${EXTRA_INSTALL_BINARIES:-"@:"} @@ -11922,7 +11922,7 @@ cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log=" -This file was extended by tcl $as_me 9.0, which was +This file was extended by tcl $as_me 9.1, which was generated by GNU Autoconf 2.72. Invocation command line was CONFIG_FILES = $CONFIG_FILES @@ -11981,7 +11981,7 @@ ac_cs_config_escaped=`printf "%s\n" "$ac_cs_config" | sed "s/^ //; s/'/'\\\\\\\\ cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_config='$ac_cs_config_escaped' ac_cs_version="\\ -tcl config.status 9.0 +tcl config.status 9.1 configured by $0, generated by GNU Autoconf 2.72, with options \\"\$ac_cs_config\\" diff --git a/unix/configure.ac b/unix/configure.ac index 80d676d..6a531b8 100644 --- a/unix/configure.ac +++ b/unix/configure.ac @@ -3,8 +3,8 @@ dnl This file is an input file used by the GNU "autoconf" program to dnl generate the file "configure", which is run during Tcl installation dnl to configure the system for the local environment. -AC_INIT([tcl],[9.0]) -AC_PREREQ([2.69]) +AC_INIT([tcl],[9.1]) +AC_PREREQ([2.72]) dnl This is only used when included from macosx/configure.ac m4_ifdef([SC_USE_CONFIG_HEADERS], [ @@ -23,10 +23,10 @@ m4_ifdef([SC_USE_CONFIG_HEADERS], [ #endif /* _TCLCONFIG */]) ]) -TCL_VERSION=9.0 +TCL_VERSION=9.1 TCL_MAJOR_VERSION=9 -TCL_MINOR_VERSION=0 -TCL_PATCH_LEVEL=".3" +TCL_MINOR_VERSION=1 +TCL_PATCH_LEVEL="a1" VERSION=${TCL_VERSION} EXTRA_INSTALL_BINARIES=${EXTRA_INSTALL_BINARIES:-"@:"} diff --git a/unix/dltest/Makefile.in b/unix/dltest/Makefile.in index 06d0e30..e42b4e8 100644 --- a/unix/dltest/Makefile.in +++ b/unix/dltest/Makefile.in @@ -27,13 +27,13 @@ CC_SWITCHES = $(CFLAGS) -I${SRC_DIR}/../../generic \ all: embtest tcl9pkga${SHLIB_SUFFIX} tcl9pkgb${SHLIB_SUFFIX} tcl9pkgc${SHLIB_SUFFIX} \ tcl9pkgd${SHLIB_SUFFIX} tcl9pkge${SHLIB_SUFFIX} tcl9pkgt${SHLIB_SUFFIX} tcl9pkgua${SHLIB_SUFFIX} \ - tcl9pkgooa${SHLIB_SUFFIX} pkga${SHLIB_SUFFIX} pkgb${SHLIB_SUFFIX} pkgc${SHLIB_SUFFIX} pkgt${SHLIB_SUFFIX} + tcl9pkgooa${SHLIB_SUFFIX} @if test -n "$(DLTEST_SUFFIX)"; then $(MAKE) dltest_suffix; fi @touch ../dltest.marker dltest_suffix: tcl9pkga${DLTEST_SUFFIX} tcl9pkgb${DLTEST_SUFFIX} tcl9pkgc${DLTEST_SUFFIX} \ tcl9pkgd${DLTEST_SUFFIX} tcl9pkge${DLTEST_SUFFIX} tcl9pkgt${DLTEST_SUFFIX} tcl9pkgua${DLTEST_SUFFIX} \ - tcl9pkgooa${DLTEST_SUFFIX} pkga${DLTEST_SUFFIX} pkgb${DLTEST_SUFFIX} pkgc${DLTEST_SUFFIX} pkgt${DLTEST_SUFFIX} + tcl9pkgooa${DLTEST_SUFFIX} @touch ../dltest.marker embtest.o: $(SRC_DIR)/embtest.c @@ -54,18 +54,6 @@ pkgc.o: $(SRC_DIR)/pkgc.c pkgt.o: $(SRC_DIR)/pkgt.c $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkgt.c -tcl8pkga.o: $(SRC_DIR)/pkga.c - $(CC) -o $@ -c $(CC_SWITCHES) -DTCL_MAJOR_VERSION=8 $(SRC_DIR)/pkga.c - -tcl8pkgb.o: $(SRC_DIR)/pkgb.c - $(CC) -o $@ -c $(CC_SWITCHES) -DTCL_MAJOR_VERSION=8 $(SRC_DIR)/pkgb.c - -tcl8pkgc.o: $(SRC_DIR)/pkgc.c - $(CC) -o $@ -c $(CC_SWITCHES) -DTCL_MAJOR_VERSION=8 $(SRC_DIR)/pkgc.c - -tcl8pkgt.o: $(SRC_DIR)/pkgt.c - $(CC) -o $@ -c $(CC_SWITCHES) -DTCL_MAJOR_VERSION=8 $(SRC_DIR)/pkgt.c - pkgd.o: $(SRC_DIR)/pkgd.c $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkgd.c @@ -96,18 +84,6 @@ tcl9pkgc${SHLIB_SUFFIX}: pkgc.o tcl9pkgt${SHLIB_SUFFIX}: pkgt.o ${SHLIB_LD} -o $@ pkgt.o ${SHLIB_LD_LIBS} -pkga${SHLIB_SUFFIX}: tcl8pkga.o - ${SHLIB_LD} -o $@ tcl8pkga.o ${SHLIB_LD_LIBS} - -pkgb${SHLIB_SUFFIX}: tcl8pkgb.o - ${SHLIB_LD} -o $@ tcl8pkgb.o ${SHLIB_LD_LIBS} - -pkgc${SHLIB_SUFFIX}: tcl8pkgc.o - ${SHLIB_LD} -o $@ tcl8pkgc.o ${SHLIB_LD_LIBS} - -pkgt${SHLIB_SUFFIX}: tcl8pkgt.o - ${SHLIB_LD} -o $@ tcl8pkgt.o ${SHLIB_LD_LIBS} - tcl9pkgd${SHLIB_SUFFIX}: pkgd.o ${SHLIB_LD} -o $@ pkgd.o ${SHLIB_LD_LIBS} @@ -135,18 +111,6 @@ tcl9pkgc${DLTEST_SUFFIX}: pkgc.o tcl9pkgt${DLTEST_SUFFIX}: pkgt.o ${DLTEST_LD} -o $@ pkgt.o ${SHLIB_LD_LIBS} -pkga${DLTEST_SUFFIX}: tcl8pkga.o - ${DLTEST_LD} -o $@ tcl8pkga.o ${SHLIB_LD_LIBS} - -pkgb${DLTEST_SUFFIX}: tcl8pkgb.o - ${DLTEST_LD} -o $@ tcl8pkgb.o ${SHLIB_LD_LIBS} - -pkgc${DLTEST_SUFFIX}: tcl8pkgc.o - ${DLTEST_LD} -o $@ tcl8pkgc.o ${SHLIB_LD_LIBS} - -pkgt${DLTEST_SUFFIX}: tcl8pkgt.o - ${DLTEST_LD} -o $@ tcl8pkgt.o ${SHLIB_LD_LIBS} - tcl9pkgd${DLTEST_SUFFIX}: pkgd.o ${DLTEST_LD} -o $@ pkgd.o ${SHLIB_LD_LIBS} diff --git a/unix/tcl.m4 b/unix/tcl.m4 index ce01ee8..dbe61c5 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -93,11 +93,11 @@ AC_DEFUN([SC_PATH_TCLCONFIG], [ `ls -d /usr/local/lib 2>/dev/null` \ `ls -d /usr/contrib/lib 2>/dev/null` \ `ls -d /usr/pkg/lib 2>/dev/null` \ - `ls -d /usr/lib/tcl9.0 2>/dev/null` \ + `ls -d /usr/lib/tcl9.1 2>/dev/null` \ `ls -d /usr/lib 2>/dev/null` \ `ls -d /usr/lib64 2>/dev/null` \ - `ls -d /usr/local/lib/tcl9.0 2>/dev/null` \ - `ls -d /usr/local/lib/tcl/tcl9.0 2>/dev/null` \ + `ls -d /usr/local/lib/tcl9.1 2>/dev/null` \ + `ls -d /usr/local/lib/tcl/tcl9.1 2>/dev/null` \ ; do if test -f "$i/tclConfig.sh" ; then ac_cv_c_tclconfig="`(cd $i; pwd)`" @@ -226,11 +226,11 @@ AC_DEFUN([SC_PATH_TKCONFIG], [ `ls -d /usr/local/lib 2>/dev/null` \ `ls -d /usr/contrib/lib 2>/dev/null` \ `ls -d /usr/pkg/lib 2>/dev/null` \ - `ls -d /usr/lib/tk9.0 2>/dev/null` \ + `ls -d /usr/lib/tk9.1 2>/dev/null` \ `ls -d /usr/lib 2>/dev/null` \ `ls -d /usr/lib64 2>/dev/null` \ - `ls -d /usr/local/lib/tk9.0 2>/dev/null` \ - `ls -d /usr/local/lib/tcl/tk9.0 2>/dev/null` \ + `ls -d /usr/local/lib/tk9.1 2>/dev/null` \ + `ls -d /usr/local/lib/tcl/tk9.1 2>/dev/null` \ ; do if test -f "$i/tkConfig.sh" ; then ac_cv_c_tkconfig="`(cd $i; pwd)`" diff --git a/unix/tcl.spec b/unix/tcl.spec index ca45a5a..204d1be 100644 --- a/unix/tcl.spec +++ b/unix/tcl.spec @@ -4,7 +4,7 @@ Name: tcl Summary: Tcl scripting language development environment -Version: 9.0.3 +Version: 9.1a1 Release: 2 License: BSD Group: Development/Languages diff --git a/unix/tclEpollNotfy.c b/unix/tclEpollNotfy.c index 1446903..877a4b9 100644 --- a/unix/tclEpollNotfy.c +++ b/unix/tclEpollNotfy.c @@ -233,23 +233,22 @@ PlatformEventsControl( */ return; } else if (epoll_ctl(tsdPtr->eventsFd, op, filePtr->fd, &newEvent) == -1) { - switch (errno) { - case EPERM: - switch (op) { - case EPOLL_CTL_ADD: - if (isNew) { - LIST_INSERT_HEAD(&tsdPtr->firstReadyFileHandlerPtr, filePtr, - readyNode); - } - break; - case EPOLL_CTL_DEL: - LIST_REMOVE(filePtr, readyNode); - break; - + switch (errno) { + case EPERM: + switch (op) { + case EPOLL_CTL_ADD: + if (isNew) { + LIST_INSERT_HEAD(&tsdPtr->firstReadyFileHandlerPtr, filePtr, + readyNode); } break; - default: - Tcl_Panic("epoll_ctl: %s", strerror(errno)); + case EPOLL_CTL_DEL: + LIST_REMOVE(filePtr, readyNode); + break; + } + break; + default: + Tcl_Panic("epoll_ctl: %s", strerror(errno)); } } return; diff --git a/unix/tclKqueueNotfy.c b/unix/tclKqueueNotfy.c index a99f7bd..b9ebd49 100644 --- a/unix/tclKqueueNotfy.c +++ b/unix/tclKqueueNotfy.c @@ -40,7 +40,7 @@ typedef struct FileHandler { * for this file. */ Tcl_FileProc *proc; /* Function to call, in the style of * Tcl_CreateFileHandler. */ - void *clientData; /* Argument to pass to proc. */ + void *clientData; /* Argument to pass to proc. */ struct FileHandler *nextPtr;/* Next in list of all files we care about. */ LIST_ENTRY(FileHandler) readyNode; /* Next/previous in list of FileHandlers asso- @@ -517,7 +517,7 @@ TclpCreateFileHandler( * called. */ Tcl_FileProc *proc, /* Function to call for each selected * event. */ - void *clientData) /* Arbitrary data to pass to proc. */ + void *clientData) /* Arbitrary data to pass to proc. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); FileHandler *filePtr = LookUpFileHandler(tsdPtr, fd, NULL); @@ -786,7 +786,7 @@ int TclAsyncNotifier( int sigNumber, /* Signal number. */ Tcl_ThreadId threadId, /* Target thread. */ - void *clientData, /* Notifier data. */ + void *clientData, /* Notifier data. */ int *flagPtr, /* Flag to mark. */ int value) /* Value of mark. */ { diff --git a/unix/tclLoadDyld.c b/unix/tclLoadDyld.c index c5422f8..6beef6b 100644 --- a/unix/tclLoadDyld.c +++ b/unix/tclLoadDyld.c @@ -81,7 +81,7 @@ TclpDlopen( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Obj *pathPtr, /* Name of the file containing the desired * code (UTF-8). */ - Tcl_LoadHandle *loadHandle, /* Filled with token for dynamically loaded + Tcl_LoadHandle *loadHandle, /* Filled with token for dynamically loaded * file which will be passed back to * (*unloadProcPtr)() to unload the file. */ Tcl_FSUnloadFileProc **unloadProcPtr, @@ -386,11 +386,11 @@ TclpLoadMemory( void *buffer, /* Buffer containing the desired code * (allocated with TclpLoadMemoryGetBuffer). */ size_t size, /* Allocation size of buffer. */ - Tcl_Size codeSize, /* Size of code data read into buffer or -1 if + Tcl_Size codeSize, /* Size of code data read into buffer or -1 if * an error occurred and the buffer should * just be freed. */ const char *path, - Tcl_LoadHandle *loadHandle, /* Filled with token for dynamically loaded + Tcl_LoadHandle *loadHandle, /* Filled with token for dynamically loaded * file which will be passed back to * (*unloadProcPtr)() to unload the file. */ Tcl_FSUnloadFileProc **unloadProcPtr, @@ -424,7 +424,7 @@ TclpLoadMemory( # define mh_size sizeof(struct mach_header_64) # define mh_magic MH_MAGIC_64 # define arch_abi CPU_ARCH_ABI64 -#endif /* __LP64__ */ +#endif /* __LP64__ */ if ((size_t)codeSize >= sizeof(struct fat_header) && fh->magic == OSSwapHostToBigInt32(FAT_MAGIC)) { @@ -466,7 +466,7 @@ TclpLoadMemory( ms = codeSize; } if (ms && !(ms >= mh_size && mh->magic == mh_magic && - mh->filetype == MH_BUNDLE)) { + mh->filetype == MH_BUNDLE)) { err = NSObjectFileImageInappropriateFile; } if (err == NSObjectFileImageSuccess) { diff --git a/unix/tclUnixChan.c b/unix/tclUnixChan.c index 7a44b1e..b256e77 100644 --- a/unix/tclUnixChan.c +++ b/unix/tclUnixChan.c @@ -1199,11 +1199,13 @@ TtyGetOptionProc( tcgetattr(fsPtr->fileState.fd, &iostate); Tcl_DStringInit(&ds); - Tcl_ExternalToUtfDStringEx(NULL, NULL, (char *) &iostate.c_cc[VSTART], 1, TCL_ENCODING_PROFILE_TCL8, &ds, NULL); + Tcl_ExternalToUtfDStringEx(NULL, NULL, (char *) &iostate.c_cc[VSTART], + 1, TCL_ENCODING_PROFILE_TCL8, &ds, NULL); Tcl_DStringAppendElement(dsPtr, Tcl_DStringValue(&ds)); TclDStringClear(&ds); - Tcl_ExternalToUtfDStringEx(NULL, NULL, (char *) &iostate.c_cc[VSTOP], 1, TCL_ENCODING_PROFILE_TCL8, &ds, NULL); + Tcl_ExternalToUtfDStringEx(NULL, NULL, (char *) &iostate.c_cc[VSTOP], + 1, TCL_ENCODING_PROFILE_TCL8, &ds, NULL); Tcl_DStringAppendElement(dsPtr, Tcl_DStringValue(&ds)); Tcl_DStringFree(&ds); } diff --git a/unix/tclUnixCompat.c b/unix/tclUnixCompat.c index 94178bf..ee3f20d 100644 --- a/unix/tclUnixCompat.c +++ b/unix/tclUnixCompat.c @@ -555,7 +555,7 @@ TclpGetHostByName( int local_errno; return gethostbyname_r(name, &tsdPtr->hent, tsdPtr->hbuf, - sizeof(tsdPtr->hbuf), &local_errno); + sizeof(tsdPtr->hbuf), &local_errno); #elif defined(HAVE_GETHOSTBYNAME_R_6) struct hostent *hePtr = NULL; diff --git a/unix/tclUnixFCmd.c b/unix/tclUnixFCmd.c index df0cd00..87d0185 100644 --- a/unix/tclUnixFCmd.c +++ b/unix/tclUnixFCmd.c @@ -2317,7 +2317,8 @@ TclpCreateTemporaryDirectory( if (dirObj) { string = TclGetString(dirObj); - if (Tcl_UtfToExternalDStringEx(NULL, NULL, string, dirObj->length, 0, &templ, NULL) != TCL_OK) { + if (Tcl_UtfToExternalDStringEx(NULL, NULL, string, dirObj->length, 0, + &templ, NULL) != TCL_OK) { return NULL; } } else { @@ -2332,7 +2333,8 @@ TclpCreateTemporaryDirectory( if (basenameObj) { string = TclGetString(basenameObj); if (basenameObj->length) { - if (Tcl_UtfToExternalDStringEx(NULL, NULL, string, basenameObj->length, 0, &tmp, NULL) != TCL_OK) { + if (Tcl_UtfToExternalDStringEx(NULL, NULL, string, basenameObj->length, + 0, &tmp, NULL) != TCL_OK) { Tcl_DStringFree(&templ); return NULL; } diff --git a/unix/tclUnixFile.c b/unix/tclUnixFile.c index 91e9ffb..5c13e09 100644 --- a/unix/tclUnixFile.c +++ b/unix/tclUnixFile.c @@ -154,7 +154,8 @@ TclpFindExecutable( if (name[0] == '/') #endif { - Tcl_ExternalToUtfDStringEx(NULL, NULL, name, TCL_INDEX_NONE, TCL_ENCODING_PROFILE_TCL8, &utfName, NULL); + Tcl_ExternalToUtfDStringEx(NULL, NULL, name, TCL_INDEX_NONE, + TCL_ENCODING_PROFILE_TCL8, &utfName, NULL); TclSetObjNameOfExecutable(Tcl_DStringToObj(&utfName), NULL); goto done; } @@ -604,7 +605,8 @@ TclpGetUserHome( Tcl_DString ds; const char *native; - if (Tcl_UtfToExternalDStringEx(NULL, NULL, name, TCL_INDEX_NONE, 0, &ds, NULL) != TCL_OK) { + if (Tcl_UtfToExternalDStringEx(NULL, NULL, name, TCL_INDEX_NONE, 0, &ds, + NULL) != TCL_OK) { Tcl_DStringFree(&ds); return NULL; } @@ -616,7 +618,8 @@ TclpGetUserHome( if (pwPtr == NULL) { return NULL; } - if (Tcl_ExternalToUtfDStringEx(NULL, NULL, pwPtr->pw_dir, TCL_INDEX_NONE, 0, bufferPtr, NULL) != TCL_OK) { + if (Tcl_ExternalToUtfDStringEx(NULL, NULL, pwPtr->pw_dir, TCL_INDEX_NONE, + 0, bufferPtr, NULL) != TCL_OK) { return NULL; } else { return Tcl_DStringValue(bufferPtr); @@ -798,7 +801,8 @@ TclpGetCwd( } return NULL; } - if (Tcl_ExternalToUtfDStringEx(interp, NULL, buffer, TCL_INDEX_NONE, 0, bufferPtr, NULL) != TCL_OK) { + if (Tcl_ExternalToUtfDStringEx(interp, NULL, buffer, TCL_INDEX_NONE, 0, + bufferPtr, NULL) != TCL_OK) { return NULL; } return Tcl_DStringValue(bufferPtr); @@ -1089,7 +1093,8 @@ TclpNativeToNormalized( { Tcl_DString ds; - Tcl_ExternalToUtfDStringEx(NULL, NULL, (const char *) clientData, TCL_INDEX_NONE, TCL_ENCODING_PROFILE_TCL8, &ds, NULL); + Tcl_ExternalToUtfDStringEx(NULL, NULL, (const char *) clientData, + TCL_INDEX_NONE, TCL_ENCODING_PROFILE_TCL8, &ds, NULL); return Tcl_DStringToObj(&ds); } diff --git a/unix/tclUnixInit.c b/unix/tclUnixInit.c index f276e71..ef62400 100644 --- a/unix/tclUnixInit.c +++ b/unix/tclUnixInit.c @@ -441,7 +441,8 @@ TclpInitLibraryPath( */ str = getenv("TCL_LIBRARY"); /* INTL: Native. */ - Tcl_ExternalToUtfDStringEx(NULL, NULL, str, TCL_INDEX_NONE, TCL_ENCODING_PROFILE_TCL8, &buffer, NULL); + Tcl_ExternalToUtfDStringEx(NULL, NULL, str, TCL_INDEX_NONE, + TCL_ENCODING_PROFILE_TCL8, &buffer, NULL); str = Tcl_DStringValue(&buffer); if ((str != NULL) && (str[0] != '\0')) { @@ -572,7 +573,7 @@ SearchKnownEncodings( int code = strcmp(localeTable[test].lang, encoding); if (code == 0) { - /* Found it at i == test. */ + /* Found it at i == test. */ return localeTable[test].encoding; } if (code < 0) { @@ -693,6 +694,12 @@ Tcl_GetEncodingNameFromEnvironment( return Tcl_DStringAppend(bufPtr, TCL_DEFAULT_ENCODING, TCL_INDEX_NONE); } +const char * +Tcl_GetEncodingNameForUser(Tcl_DString *bufPtr) +{ + return Tcl_GetEncodingNameFromEnvironment(bufPtr); +} + /* *--------------------------------------------------------------------------- * diff --git a/unix/tclUnixPipe.c b/unix/tclUnixPipe.c index e1ee872..126e938 100644 --- a/unix/tclUnixPipe.c +++ b/unix/tclUnixPipe.c @@ -213,7 +213,8 @@ TclpCreateTempFile( Tcl_DString dstring; char *native; - if (Tcl_UtfToExternalDStringEx(NULL, NULL, contents, TCL_INDEX_NONE, 0, &dstring, NULL) != TCL_OK) { + if (Tcl_UtfToExternalDStringEx(NULL, NULL, contents, TCL_INDEX_NONE, + 0, &dstring, NULL) != TCL_OK) { close(fd); Tcl_DStringFree(&dstring); return NULL; @@ -462,7 +463,8 @@ TclpCreateProcess( newArgv = (char **)TclStackAlloc(interp, (argc+1) * sizeof(char *)); newArgv[argc] = NULL; for (i = 0; i < argc; i++) { - if (Tcl_UtfToExternalDStringEx(interp, NULL, argv[i], TCL_INDEX_NONE, 0, &dsArray[i], NULL) != TCL_OK) { + if (Tcl_UtfToExternalDStringEx(interp, NULL, argv[i], TCL_INDEX_NONE, + 0, &dsArray[i], NULL) != TCL_OK) { while (i-- > 0) { Tcl_DStringFree(&dsArray[i]); } diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c index 8474bcf..eed898b 100644 --- a/unix/tclUnixSock.c +++ b/unix/tclUnixSock.c @@ -180,24 +180,6 @@ static TclInitProcessGlobalValueProc InitializeHostName; static ProcessGlobalValue hostName = {0, 0, NULL, NULL, InitializeHostName, NULL, NULL}; -#if 0 -/* printf debugging */ -void -printaddrinfo( - struct addrinfo *addrlist, - char *prefix) -{ - char host[NI_MAXHOST], port[NI_MAXSERV]; - struct addrinfo *ai; - - for (ai = addrlist; ai != NULL; ai = ai->ai_next) { - getnameinfo(ai->ai_addr, ai->ai_addrlen, - host, sizeof(host), port, sizeof(port), - NI_NUMERICHOST|NI_NUMERICSERV); - fprintf(stderr,"%s: %s:%s\n", prefix, host, port); - } -} -#endif /* * ---------------------------------------------------------------------- * @@ -1107,15 +1089,15 @@ TcpThreadActionProc( * so the callback will run in the correct thread, bug [f583715154]. */ switch (action) { - case TCL_CHANNEL_THREAD_REMOVE: + case TCL_CHANNEL_THREAD_REMOVE: CLEAR_BITS(statePtr->flags, TCP_ASYNC_PENDING); Tcl_DeleteFileHandler(statePtr->fds.fd); - break; - case TCL_CHANNEL_THREAD_INSERT: + break; + case TCL_CHANNEL_THREAD_INSERT: Tcl_CreateFileHandler(statePtr->fds.fd, - TCL_WRITABLE | TCL_EXCEPTION, TcpAsyncCallback, statePtr); + TCL_WRITABLE | TCL_EXCEPTION, TcpAsyncCallback, statePtr); SET_BITS(statePtr->flags, TCP_ASYNC_PENDING); - break; + break; } } } @@ -1681,7 +1663,7 @@ Tcl_OpenTcpServerEx( int retry = 0; #define MAXRETRY 10 - repeat: + repeat: if (retry > 0) { if (statePtr != NULL) { TcpCloseProc(statePtr, NULL); diff --git a/unix/tclUnixTest.c b/unix/tclUnixTest.c index cb0c5cd..46e2db9 100644 --- a/unix/tclUnixTest.c +++ b/unix/tclUnixTest.c @@ -312,7 +312,7 @@ TestfilehandlerCmd( static void TestFileHandlerProc( - void *clientData, /* Points to a Pipe structure. */ + void *clientData, /* Points to a Pipe structure. */ int mask) /* Indicates which events happened: * TCL_READABLE or TCL_WRITABLE. */ { @@ -611,9 +611,9 @@ TestgotsigCmd( static int TestchmodCmd( TCL_UNUSED(void *), - Tcl_Interp *interp, /* Current interpreter. */ + Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *const *objv) /* Argument strings. */ + Tcl_Obj *const *objv) /* Argument strings. */ { int i, mode; Tcl_DString ds; diff --git a/unix/tclUnixThrd.c b/unix/tclUnixThrd.c index 24bc72d..ae22e46 100644 --- a/unix/tclUnixThrd.c +++ b/unix/tclUnixThrd.c @@ -213,8 +213,8 @@ int TclpThreadCreate( Tcl_ThreadId *idPtr, /* Return, the ID of the thread */ Tcl_ThreadCreateProc *proc, /* Main() function of the thread */ - void *clientData, /* The one argument to Main() */ - size_t stackSize, /* Size of stack for the new thread */ + void *clientData, /* The one argument to Main() */ + size_t stackSize, /* Size of stack for the new thread */ int flags) /* Flags controlling behaviour of the new * thread. */ { @@ -672,7 +672,7 @@ void Tcl_ConditionWait( Tcl_Condition *condPtr, /* Really (pthread_cond_t **) */ Tcl_Mutex *mutexPtr, /* Really (PMutex **) */ - const Tcl_Time *timePtr) /* Timeout on waiting period */ + const Tcl_Time *timePtr) /* Timeout on waiting period */ { pthread_cond_t *pcondPtr; PMutex *pmutexPtr; diff --git a/unix/tclXtNotify.c b/unix/tclXtNotify.c index 8ca2c5f..6d4e3c9 100644 --- a/unix/tclXtNotify.c +++ b/unix/tclXtNotify.c @@ -33,7 +33,7 @@ typedef struct FileHandler { XtInputId except; /* Xt exception callback handle. */ Tcl_FileProc *proc; /* Procedure to call, in the style of * Tcl_CreateFileHandler. */ - void *clientData; /* Argument to pass to proc. */ + void *clientData; /* Argument to pass to proc. */ struct FileHandler *nextPtr;/* Next in list of all files we care about. */ } FileHandler; @@ -263,7 +263,7 @@ NotifierExitHandler( static void SetTimer( - const Tcl_Time *timePtr) /* Timeout value, may be NULL. */ + const Tcl_Time *timePtr) /* Timeout value, may be NULL. */ { unsigned long timeout; @@ -339,7 +339,7 @@ CreateFileHandler( * called. */ Tcl_FileProc *proc, /* Procedure to call for each selected * event. */ - void *clientData) /* Arbitrary data to pass to proc. */ + void *clientData) /* Arbitrary data to pass to proc. */ { FileHandler *filePtr; @@ -627,7 +627,7 @@ FileHandlerEventProc( static int WaitForEvent( - const Tcl_Time *timePtr) /* Maximum block time, or NULL. */ + const Tcl_Time *timePtr) /* Maximum block time, or NULL. */ { int timeout; diff --git a/win/Makefile.in b/win/Makefile.in index e039f64..4f1d8ef 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -151,17 +151,15 @@ TCL_STUB_LIB_FILE = @TCL_STUB_LIB_FILE@ TCL_DLL_FILE = @TCL_DLL_FILE@ TCL_LIB_FILE = @TCL_LIB_FILE@ DDE_DLL_FILE = tcl9dde$(DDEVER)${DLLSUFFIX} -DDE_DLL_FILE8 = tcldde$(DDEVER)${DLLSUFFIX} DDE_LIB_FILE = @LIBPREFIX@tcldde$(DDEVER)${DLLSUFFIX}${LIBSUFFIX} REG_DLL_FILE = tcl9registry$(REGVER)${DLLSUFFIX} -REG_DLL_FILE8 = tclregistry$(REGVER)${DLLSUFFIX} REG_LIB_FILE = @LIBPREFIX@tclregistry$(REGVER)${DLLSUFFIX}${LIBSUFFIX} TEST_DLL_FILE = tcltest$(VER)${DLLSUFFIX} TEST_EXE_FILE = tcltest${EXESUFFIX} TEST_LIB_FILE = @LIBPREFIX@tcltest$(VER)${DLLSUFFIX}${LIBSUFFIX} TEST_LOAD_PRMS = lappend ::auto_path {$(ROOT_DIR_WIN_NATIVE)/tests};\ - package ifneeded dde 1.4.5 [list load ${DDE_DLL_FILE}];\ - package ifneeded registry 1.3.7 [list load ${REG_DLL_FILE}] + package ifneeded dde 1.5a1 [list load ${DDE_DLL_FILE}];\ + package ifneeded registry 1.4a1 [list load ${REG_DLL_FILE}] TEST_LOAD_FACILITIES = package ifneeded tcl::test ${VERSION}@TCL_PATCH_LEVEL@ [list load ${TEST_DLL_FILE} Tcltest];\ $(TEST_LOAD_PRMS) ZLIB_DLL_FILE = zlib1.dll @@ -334,6 +332,7 @@ GENERIC_OBJS = \ tclLink.$(OBJEXT) \ tclLiteral.$(OBJEXT) \ tclListObj.$(OBJEXT) \ + tclListTypes.$(OBJEXT) \ tclLoad.$(OBJEXT) \ tclMainW.$(OBJEXT) \ tclMain.$(OBJEXT) \ @@ -534,7 +533,7 @@ tcltest: binaries $(TEST_EXE_FILE) $(TEST_DLL_FILE) $(CAT32) tcltest.cmd binaries: $(TCL_STUB_LIB_FILE) @LIBRARIES@ winextensions ${TCL_ZIP_FILE} $(TCLSH) -winextensions: ${DDE_DLL_FILE} ${REG_DLL_FILE} ${DDE_DLL_FILE8} ${REG_DLL_FILE8} +winextensions: ${DDE_DLL_FILE} ${REG_DLL_FILE} libraries: @@ -609,14 +608,6 @@ ${REG_DLL_FILE}: ${TCL_STUB_LIB_FILE} ${REG_OBJS} @MAKE_DLL@ ${REG_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS) $(COPY) tclsh.exe.manifest ${REG_DLL_FILE}.manifest -${DDE_DLL_FILE8}: ${TCL_STUB_LIB_FILE} tcl8WinDde.$(OBJEXT) - @MAKE_DLL@ tcl8WinDde.$(OBJEXT) $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS) - $(COPY) tclsh.exe.manifest ${DDE_DLL_FILE8}.manifest - -${REG_DLL_FILE8}: ${TCL_STUB_LIB_FILE} tcl8WinReg.$(OBJEXT) - @MAKE_DLL@ -DTCL_MAJOR_VERSION=8 tcl8WinReg.$(OBJEXT) $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS) - $(COPY) tclsh.exe.manifest ${REG_DLL_FILE8}.manifest - ${TEST_DLL_FILE}: ${TCL_STUB_LIB_FILE} ${TCLTEST_OBJS} @$(RM) ${TEST_DLL_FILE} ${TEST_LIB_FILE} @MAKE_DLL@ ${TCLTEST_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS) @@ -767,7 +758,7 @@ tclWinPanic.${OBJEXT}: tclWinPanic.c .rc.$(RES): $(RC) @RC_OUT@ $@ @RC_TYPE@ @RC_DEFINES@ @RC_INCLUDE@ "$(GENERIC_DIR_NATIVE)" @RC_INCLUDE@ "$(WIN_DIR_NATIVE)" @DEPARG@ - +tclOO.${OBJEXT}: tclOO.c tclOOScript.h #-------------------------------------------------------------------------- # Minizip implementation @@ -880,10 +871,6 @@ install-binaries: binaries $(COPY) $(ROOT_DIR)/library/dde/pkgIndex.tcl \ "$(LIB_INSTALL_DIR)/dde${DDEDOTVER}"; \ fi - @if [ -f $(DDE_DLL_FILE8) ]; then \ - echo Installing $(DDE_DLL_FILE8); \ - $(COPY) $(DDE_DLL_FILE8) "$(LIB_INSTALL_DIR)/dde${DDEDOTVER}"; \ - fi @if [ -f $(DDE_LIB_FILE) ]; then \ echo Installing $(DDE_LIB_FILE); \ $(COPY) $(DDE_LIB_FILE) "$(LIB_INSTALL_DIR)/dde${DDEDOTVER}"; \ @@ -894,10 +881,6 @@ install-binaries: binaries $(COPY) $(ROOT_DIR)/library/registry/pkgIndex.tcl \ "$(LIB_INSTALL_DIR)/registry${REGDOTVER}"; \ fi - @if [ -f $(REG_DLL_FILE8) ]; then \ - echo Installing $(REG_DLL_FILE8); \ - $(COPY) $(REG_DLL_FILE8) "$(LIB_INSTALL_DIR)/registry${REGDOTVER}"; \ - fi @if [ -f $(REG_LIB_FILE) ]; then \ echo Installing $(REG_LIB_FILE); \ $(COPY) $(REG_LIB_FILE) "$(LIB_INSTALL_DIR)/registry${REGDOTVER}"; \ @@ -1023,7 +1006,7 @@ test-tcl: tcltest # Useful target to launch a built tclsh with the proper path,... runtest: tcltest @TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \ - $(WINE) ./$(TCLSH) $(TESTFLAGS) -load "$(TEST_LOAD_FACILITIES)" $(SCRIPT) + $(WINE) ./$(TCLSH) $(SCRIPT) $(TESTFLAGS) -load "$(TEST_LOAD_FACILITIES)" # This target can be used to run tclsh from the build directory via # `make shell SCRIPT=foo.tcl` @@ -1,4 +1,4 @@ -Tcl 9.0 for Windows +Tcl 9.1 for Windows 1. Introduction --------------- @@ -16,7 +16,7 @@ The information in this file is maintained on the web at: In order to compile Tcl for Windows, you need the following: - Tcl 9.0 Source Distribution (plus any patches) + Tcl 9.1 Source Distribution (plus any patches) and diff --git a/win/configure b/win/configure index 8ae43b4..7781259 100755 --- a/win/configure +++ b/win/configure @@ -1,6 +1,6 @@ #! /bin/sh # Guess values for system-dependent variables and create Makefiles. -# Generated by GNU Autoconf 2.72 for tcl 9.0. +# Generated by GNU Autoconf 2.72 for tcl 9.1. # # # Copyright (C) 1992-1996, 1998-2017, 2020-2023 Free Software Foundation, @@ -601,8 +601,8 @@ MAKEFLAGS= # Identity of this package. PACKAGE_NAME='tcl' PACKAGE_TARNAME='tcl' -PACKAGE_VERSION='9.0' -PACKAGE_STRING='tcl 9.0' +PACKAGE_VERSION='9.1' +PACKAGE_STRING='tcl 9.1' PACKAGE_BUGREPORT='' PACKAGE_URL='' @@ -1357,7 +1357,7 @@ if test "$ac_init_help" = "long"; then # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF -'configure' configures tcl 9.0 to adapt to many kinds of systems. +'configure' configures tcl 9.1 to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... @@ -1419,7 +1419,7 @@ fi if test -n "$ac_init_help"; then case $ac_init_help in - short | recursive ) echo "Configuration of tcl 9.0:";; + short | recursive ) echo "Configuration of tcl 9.1:";; esac cat <<\_ACEOF @@ -1516,7 +1516,7 @@ fi test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then cat <<\_ACEOF -tcl configure 9.0 +tcl configure 9.1 generated by GNU Autoconf 2.72 Copyright (C) 2023 Free Software Foundation, Inc. @@ -1726,7 +1726,7 @@ cat >config.log <<_ACEOF This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. -It was created by tcl $as_me 9.0, which was +It was created by tcl $as_me 9.1, which was generated by GNU Autoconf 2.72. Invocation command line was $ $0$ac_configure_args_raw @@ -2408,20 +2408,20 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu # /bin/sh. The bash shell seems to suffer from some strange failures. SHELL=/bin/sh -TCL_VERSION=9.0 +TCL_VERSION=9.1 TCL_MAJOR_VERSION=9 -TCL_MINOR_VERSION=0 -TCL_PATCH_LEVEL=".3" +TCL_MINOR_VERSION=1 +TCL_PATCH_LEVEL="a1" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION -TCL_DDE_VERSION=1.4 +TCL_DDE_VERSION=1.5 TCL_DDE_MAJOR_VERSION=1 -TCL_DDE_MINOR_VERSION=4 +TCL_DDE_MINOR_VERSION=5 DDEVER=$TCL_DDE_MAJOR_VERSION$TCL_DDE_MINOR_VERSION -TCL_REG_VERSION=1.3 +TCL_REG_VERSION=1.4 TCL_REG_MAJOR_VERSION=1 -TCL_REG_MINOR_VERSION=3 +TCL_REG_MINOR_VERSION=4 REGVER=$TCL_REG_MAJOR_VERSION$TCL_REG_MINOR_VERSION PKG_CFG_ARGS=$@ @@ -6625,7 +6625,7 @@ cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log=" -This file was extended by tcl $as_me 9.0, which was +This file was extended by tcl $as_me 9.1, which was generated by GNU Autoconf 2.72. Invocation command line was CONFIG_FILES = $CONFIG_FILES @@ -6680,7 +6680,7 @@ ac_cs_config_escaped=`printf "%s\n" "$ac_cs_config" | sed "s/^ //; s/'/'\\\\\\\\ cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_config='$ac_cs_config_escaped' ac_cs_version="\\ -tcl config.status 9.0 +tcl config.status 9.1 configured by $0, generated by GNU Autoconf 2.72, with options \\"\$ac_cs_config\\" diff --git a/win/configure.ac b/win/configure.ac index b43cb85..61d4976 100644 --- a/win/configure.ac +++ b/win/configure.ac @@ -3,29 +3,29 @@ # generate the file "configure", which is run during Tcl installation # to configure the system for the local environment. -AC_INIT([tcl],[9.0]) +AC_INIT([tcl],[9.1]) AC_CONFIG_SRCDIR([../generic/tcl.h]) -AC_PREREQ([2.69]) +AC_PREREQ([2.72]) # The following define is needed when building with Cygwin since newer # versions of autoconf incorrectly set SHELL to /bin/bash instead of # /bin/sh. The bash shell seems to suffer from some strange failures. SHELL=/bin/sh -TCL_VERSION=9.0 +TCL_VERSION=9.1 TCL_MAJOR_VERSION=9 -TCL_MINOR_VERSION=0 -TCL_PATCH_LEVEL=".3" +TCL_MINOR_VERSION=1 +TCL_PATCH_LEVEL="a1" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION -TCL_DDE_VERSION=1.4 +TCL_DDE_VERSION=1.5 TCL_DDE_MAJOR_VERSION=1 -TCL_DDE_MINOR_VERSION=4 +TCL_DDE_MINOR_VERSION=5 DDEVER=$TCL_DDE_MAJOR_VERSION$TCL_DDE_MINOR_VERSION -TCL_REG_VERSION=1.3 +TCL_REG_VERSION=1.4 TCL_REG_MAJOR_VERSION=1 -TCL_REG_MINOR_VERSION=3 +TCL_REG_MINOR_VERSION=4 REGVER=$TCL_REG_MAJOR_VERSION$TCL_REG_MINOR_VERSION PKG_CFG_ARGS=$@ diff --git a/win/makefile.vc b/win/makefile.vc index ae859ba..18b9bb6 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -209,10 +209,10 @@ TCL_TEST_LIBRARY= !include versions.vc
-DDEDOTVERSION = 1.4
+DDEDOTVERSION = 1.5
DDEVERSION = $(DDEDOTVERSION:.=)
-REGDOTVERSION = 1.3
+REGDOTVERSION = 1.4
REGVERSION = $(REGDOTVERSION:.=)
TCLREGLIBNAME = $(PROJECT)9registry$(REGVERSION)$(SUFX:t=).$(EXT)
@@ -289,6 +289,7 @@ COREOBJS = \ $(TMP_DIR)\tclIORTrans.obj \
$(TMP_DIR)\tclLink.obj \
$(TMP_DIR)\tclListObj.obj \
+ $(TMP_DIR)\tclListTypes.obj \
$(TMP_DIR)\tclLiteral.obj \
$(TMP_DIR)\tclLoad.obj \
$(TMP_DIR)\tclMainW.obj \
@@ -553,8 +554,8 @@ test: test-core test-pkgs test-core: tcltest
set TCL_LIBRARY=$(TCL_TEST_LIBRARY)
$(DEBUGGER) $(TCLTEST) "$(ROOT:\=/)/tests/all.tcl" $(TESTFLAGS) -loadfile <<
- package ifneeded dde 1.4.5 [list load "$(TCLDDELIB:\=/)"]
- package ifneeded registry 1.3.7 [list load "$(TCLREGLIB:\=/)"]
+ package ifneeded dde 1.5a1 [list load "$(TCLDDELIB:\=/)"]
+ package ifneeded registry 1.4a1 [list load "$(TCLREGLIB:\=/)"]
<<
runtest: setup $(TCLTEST) dlls
@@ -995,10 +995,10 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ #------------------------------------------------------------------------ AC_DEFUN([SC_WITH_TCL], [ - if test -d ../../tcl9.0$1/win; then - TCL_BIN_DEFAULT=../../tcl9.0$1/win + if test -d ../../tcl9.1$1/win; then + TCL_BIN_DEFAULT=../../tcl9.1$1/win else - TCL_BIN_DEFAULT=../../tcl9.0/win + TCL_BIN_DEFAULT=../../tcl9.1/win fi AC_ARG_WITH(tcl, [ --with-tcl=DIR use Tcl 9.x binaries from DIR], diff --git a/win/tclWin32Dll.c b/win/tclWin32Dll.c index 3b7bbea..3d64276 100644 --- a/win/tclWin32Dll.c +++ b/win/tclWin32Dll.c @@ -434,8 +434,8 @@ TclWinDriveLetterForVolMountPoint( int TclWinCPUID( - int index, /* Which CPUID value to retrieve. */ - int *regsPtr) /* Registers after the CPUID. */ + int index, /* Which CPUID value to retrieve. */ + int *regsPtr) /* Registers after the CPUID. */ { int status = TCL_ERROR; diff --git a/win/tclWinChan.c b/win/tclWinChan.c index 393b48c..5c06e00 100644 --- a/win/tclWinChan.c +++ b/win/tclWinChan.c @@ -17,13 +17,16 @@ /* * State flags used in the info structures below. */ +enum TclWinFileInfoFlags { + FILE_PENDING = 1<<0, /* Message is pending in the queue. */ + FILE_ASYNC = 1<<1, /* Channel is non-blocking. */ + FILE_APPEND = 1<<2 /* File is in append mode. */ +}; -#define FILE_PENDING (1<<0) /* Message is pending in the queue. */ -#define FILE_ASYNC (1<<1) /* Channel is non-blocking. */ -#define FILE_APPEND (1<<2) /* File is in append mode. */ - -#define FILE_TYPE_SERIAL (FILE_TYPE_PIPE+1) -#define FILE_TYPE_CONSOLE (FILE_TYPE_PIPE+2) +enum TclWinExtraFileTypes { + FILE_TYPE_SERIAL = FILE_TYPE_PIPE + 1, + FILE_TYPE_CONSOLE = FILE_TYPE_PIPE + 2 +}; /* * The following structure contains per-instance data for a file based @@ -385,7 +388,7 @@ FileEventProc( static int FileBlockProc( - void *instanceData, /* Instance data for channel. */ + void *instanceData, /* Instance data for channel. */ int mode) /* TCL_MODE_BLOCKING or * TCL_MODE_NONBLOCKING. */ { @@ -424,7 +427,7 @@ FileBlockProc( static int FileCloseProc( - void *instanceData, /* Pointer to FileInfo structure. */ + void *instanceData, /* Pointer to FileInfo structure. */ TCL_UNUSED(Tcl_Interp *), int flags) { @@ -502,7 +505,7 @@ FileCloseProc( static long long FileWideSeekProc( - void *instanceData, /* File state. */ + void *instanceData, /* File state. */ long long offset, /* Offset to seek to. */ int mode, /* Relative to where should we seek? */ int *errorCodePtr) /* To store error code. */ @@ -554,7 +557,7 @@ FileWideSeekProc( static int FileTruncateProc( - void *instanceData, /* File state. */ + void *instanceData, /* File state. */ long long length) /* Length to truncate at. */ { FileInfo *infoPtr = (FileInfo *)instanceData; @@ -630,7 +633,7 @@ FileTruncateProc( static int FileInputProc( - void *instanceData, /* File state. */ + void *instanceData, /* File state. */ char *buf, /* Where to store data read. */ int bufSize, /* Num bytes available in buffer. */ int *errorCode) /* Where to store error code. */ @@ -685,7 +688,7 @@ FileInputProc( static int FileOutputProc( - void *instanceData, /* File state. */ + void *instanceData, /* File state. */ const char *buf, /* The data buffer. */ int toWrite, /* How many bytes to write? */ int *errorCode) /* Where to store error code. */ @@ -732,7 +735,7 @@ FileOutputProc( static void FileWatchProc( - void *instanceData, /* File state. */ + void *instanceData, /* File state. */ int mask) /* What events to watch for; OR-ed combination * of TCL_READABLE, TCL_WRITABLE and * TCL_EXCEPTION. */ @@ -771,9 +774,9 @@ FileWatchProc( static int FileGetHandleProc( - void *instanceData, /* The file state. */ + void *instanceData, /* The file state. */ int direction, /* TCL_READABLE or TCL_WRITABLE */ - void **handlePtr) /* Where to store the handle. */ + void **handlePtr) /* Where to store the handle. */ { FileInfo *infoPtr = (FileInfo *)instanceData; @@ -868,9 +871,9 @@ StatOpenFile( */ mode = (attr & FILE_ATTRIBUTE_DIRECTORY) ? S_IFDIR|S_IEXEC : S_IFREG; - mode |= (attr & FILE_ATTRIBUTE_READONLY) ? S_IREAD : S_IREAD|S_IWRITE; - mode |= (mode & (S_IREAD|S_IWRITE|S_IEXEC)) >> 3; - mode |= (mode & (S_IREAD|S_IWRITE|S_IEXEC)) >> 6; + mode = mode | (attr & FILE_ATTRIBUTE_READONLY) ? S_IREAD : S_IREAD|S_IWRITE; + mode = mode | (unsigned short)((mode & (S_IREAD|S_IWRITE|S_IEXEC)) >> 3); + mode = mode | (unsigned short)((mode & (S_IREAD|S_IWRITE|S_IEXEC)) >> 6); /* * We don't construct a Tcl_StatBuf; we're using the info immediately. @@ -906,14 +909,14 @@ StatOpenFile( static int FileGetOptionProc( - void *instanceData, /* The file state. */ + void *instanceData, /* The file state. */ Tcl_Interp *interp, /* For error reporting. */ const char *optionName, /* What option to read, or NULL for all. */ Tcl_DString *dsPtr) /* Where to write the value read. */ { FileInfo *infoPtr = (FileInfo *)instanceData; int valid = 0; /* Flag if valid option parsed. */ - int len; + size_t len; if (optionName == NULL) { len = 0; @@ -1004,13 +1007,9 @@ TclpOpenFileChannel( * Note: since paths starting with ~ are relative in 9.0 for windows, * it doesn't need to consider tilde expansion (in opposite to 8.x). */ - if ( - ( - !TclFSCwdIsNative() && - (Tcl_FSGetPathType(pathPtr) != TCL_PATH_ABSOLUTE) - ) && - Tcl_FSGetNormalizedPath(interp, pathPtr) == NULL - ) { + if (!TclFSCwdIsNative() + && (Tcl_FSGetPathType(pathPtr) != TCL_PATH_ABSOLUTE) + && Tcl_FSGetNormalizedPath(interp, pathPtr) == NULL) { return NULL; } @@ -1221,7 +1220,7 @@ TclpOpenFileChannel( Tcl_Channel Tcl_MakeFileChannel( - void *rawHandle, /* OS level handle */ + void *rawHandle, /* OS level handle */ int mode) /* OR'ed combination of TCL_READABLE and * TCL_WRITABLE to indicate file mode. */ { diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index 9e9f6c0..ec6d170 100644 --- a/win/tclWinConsole.c +++ b/win/tclWinConsole.c @@ -193,7 +193,7 @@ typedef struct ConsoleChannelInfo { Tcl_Channel channel; /* Pointer to channel structure. */ DWORD initMode; /* Initial console mode. */ int numRefs; /* See comments above */ - int permissions; /* OR'ed combination of TCL_READABLE, + int permissions; /* OR'ed combination of TCL_READABLE, * TCL_WRITABLE, or TCL_EXCEPTION: indicates * which operations are valid on the file. */ int watchMask; /* OR'ed combination of TCL_READABLE, @@ -276,7 +276,7 @@ static int RingBufferCheck(const RingBuffer *ringPtr); typedef struct { /* Currently this struct is only used to detect thread initialization */ - int notUsed; /* Dummy field */ + int notUsed; /* Dummy field */ } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; @@ -570,7 +570,7 @@ ReadConsoleChars( * or https://github.com/microsoft/terminal/issues/12143 */ nRead = (DWORD)-1; - if (!ReadConsoleW(hConsole, lpBuffer, nChars, &nRead, NULL)) { + if (!ReadConsoleW(hConsole, lpBuffer, (DWORD)nChars, &nRead, NULL)) { return GetLastError(); } if ((nRead == 0 || nRead == (DWORD)-1) @@ -610,7 +610,7 @@ WriteConsoleChars( /* See comments in ReadConsoleChars, not sure that applies here */ nCharsWritten = (DWORD)-1; - if (!WriteConsoleW(hConsole, lpBuffer, nChars, &nCharsWritten, NULL)) { + if (!WriteConsoleW(hConsole, lpBuffer, (DWORD)nChars, &nCharsWritten, NULL)) { return GetLastError(); } if (nCharsWritten == (DWORD) -1) { @@ -1190,7 +1190,7 @@ ConsoleInputProc( return -1; } else if (numChars > 0) { /* Successfully read something. */ - return numChars * sizeof(WCHAR); + return (int)(numChars * sizeof(WCHAR)); } else { /* * Ctrl-C/Ctrl-Brk interrupt. Loop around to retry. @@ -1228,7 +1228,7 @@ ConsoleInputProc( } ReleaseSRWLockExclusive(&handleInfoPtr->lock); - return numRead; + return (int)numRead; } /* @@ -1342,7 +1342,7 @@ ConsoleOutputProc( winStatus = WriteConsoleChars(consoleHandle, (WCHAR *)buf, toWrite / sizeof(WCHAR), &numWritten); if (winStatus == ERROR_SUCCESS) { - return numWritten * sizeof(WCHAR); + return (int)(numWritten * sizeof(WCHAR)); } else { Tcl_WinConvertError(winStatus); *errorCode = Tcl_GetErrno(); @@ -1354,7 +1354,7 @@ ConsoleOutputProc( } WakeConditionVariable(&handleInfoPtr->consoleThreadCV); ReleaseSRWLockExclusive(&handleInfoPtr->lock); - return numWritten; + return (int)numWritten; } /* @@ -1867,7 +1867,7 @@ ConsoleWriterThread( while (1) { /* handleInfoPtr->lock must be held on entry to loop */ - int offset; + Tcl_Size offset; HANDLE consoleHandle; /* @@ -2000,7 +2000,7 @@ ConsoleWriterThread( static ConsoleHandleInfo * AllocateConsoleHandleInfo( HANDLE consoleHandle, - int permissions) /* TCL_READABLE or TCL_WRITABLE */ + int permissions) /* TCL_READABLE or TCL_WRITABLE */ { ConsoleHandleInfo *handleInfoPtr; DWORD consoleMode; @@ -2265,8 +2265,8 @@ ConsoleSetOptionProc( const char *value) /* New value for option. */ { ConsoleChannelInfo *chanInfoPtr = (ConsoleChannelInfo *)instanceData; - int len = strlen(optionName); - int vlen = strlen(value); + size_t len = strlen(optionName); + size_t vlen = strlen(value); /* * Option -inputmode normal|password|raw @@ -2355,7 +2355,7 @@ ConsoleGetOptionProc( { ConsoleChannelInfo *chanInfoPtr = (ConsoleChannelInfo *)instanceData; int valid = 0; /* Flag if valid option parsed. */ - unsigned int len; + size_t len; char buf[TCL_INTEGER_SPACE]; if (optionName == NULL) { diff --git a/win/tclWinDde.c b/win/tclWinDde.c index ebcd736..4e05ca7 100644 --- a/win/tclWinDde.c +++ b/win/tclWinDde.c @@ -79,33 +79,19 @@ static DWORD ddeInstance; /* The application instance handle given to us * by DdeInitialize. */ static int ddeIsServer = 0; -#define TCL_DDE_VERSION "1.4.5" +#define TCL_DDE_VERSION "1.5a1" #define TCL_DDE_PACKAGE_NAME "dde" #define TCL_DDE_SERVICE_NAME L"TclEval" #define TCL_DDE_EXECUTE_RESULT L"$TCLEVAL$EXECUTE$RESULT" -#define DDE_FLAG_ASYNC 1 -#define DDE_FLAG_BINARY 2 -#define DDE_FLAG_FORCE 4 +enum TclDdeFlags { + DDE_FLAG_ASYNC = 1, + DDE_FLAG_BINARY = 2, + DDE_FLAG_FORCE = 4 +}; TCL_DECLARE_MUTEX(ddeMutex) -#if (TCL_MAJOR_VERSION < 9) && defined(TCL_MINOR_VERSION) && (TCL_MINOR_VERSION < 7) -# if TCL_UTF_MAX > 3 -# define Tcl_WCharToUtfDString(a,b,c) Tcl_WinTCharToUtf((TCHAR *)(a),(b)*sizeof(WCHAR),c) -# define Tcl_UtfToWCharDString(a,b,c) (WCHAR *)Tcl_WinUtfToTChar(a,b,c) -# else -# define Tcl_WCharToUtfDString Tcl_UniCharToUtfDString -# define Tcl_UtfToWCharDString Tcl_UtfToUniCharDString -# endif -#ifndef Tcl_Size -# define Tcl_Size int -#endif -#ifndef Tcl_CreateObjCommand2 -# define Tcl_CreateObjCommand2 Tcl_CreateObjCommand -#endif -#endif - /* * Declarations for functions defined in this file. */ @@ -138,11 +124,6 @@ extern "C" { #endif DLLEXPORT int Dde_Init(Tcl_Interp *interp); DLLEXPORT int Dde_SafeInit(Tcl_Interp *interp); -#if TCL_MAJOR_VERSION < 9 -/* With those additional entries, "load tcldde14.dll" works without 3th argument */ -DLLEXPORT int Tcldde_Init(Tcl_Interp *interp); -DLLEXPORT int Tcldde_SafeInit(Tcl_Interp *interp); -#endif #ifdef __cplusplus } #endif @@ -175,14 +156,6 @@ Dde_Init( Tcl_CreateExitHandler(DdeExitProc, NULL); return Tcl_PkgProvideEx(interp, TCL_DDE_PACKAGE_NAME, TCL_DDE_VERSION, NULL); } -#if TCL_MAJOR_VERSION < 9 -int -Tcldde_Init( - Tcl_Interp *interp) -{ - return Dde_Init(interp); -} -#endif /* *---------------------------------------------------------------------- @@ -210,14 +183,6 @@ Dde_SafeInit( } return result; } -#if TCL_MAJOR_VERSION < 9 -int -Tcldde_SafeInit( - Tcl_Interp *interp) -{ - return Dde_SafeInit(interp); -} -#endif /* *---------------------------------------------------------------------- @@ -381,7 +346,8 @@ DdeSetServerName( } if (r != TCL_OK) { Tcl_DStringInit(&dString); - OutputDebugStringW(Tcl_UtfToWCharDString(Tcl_GetString(Tcl_GetObjResult(interp)), -1, &dString)); + OutputDebugStringW(Tcl_UtfToWCharDString( + Tcl_GetString(Tcl_GetObjResult(interp)), -1, &dString)); Tcl_DStringFree(&dString); return NULL; } @@ -1565,8 +1531,8 @@ DdeObjCmd( } if (dataLength + 1 < 2) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("cannot execute null data", -1)); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "cannot execute null data", -1)); Tcl_DStringFree(&dsBuf); Tcl_SetErrorCode(interp, "TCL", "DDE", "NULL", (char *)NULL); result = TCL_ERROR; @@ -1616,8 +1582,8 @@ DdeObjCmd( length = Tcl_DStringLength(&itemBuf) / sizeof(WCHAR); if (length == 0) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("cannot request value of null data", -1)); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "cannot request value of null data", -1)); Tcl_SetErrorCode(interp, "TCL", "DDE", "NULL", (char *)NULL); result = TCL_ERROR; goto cleanup; @@ -1682,8 +1648,8 @@ DdeObjCmd( itemString = Tcl_UtfToWCharDString(src, length, &itemBuf); length = Tcl_DStringLength(&itemBuf) / sizeof(WCHAR); if (length == 0) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("cannot have a null item", -1)); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "cannot have a null item", -1)); Tcl_SetErrorCode(interp, "TCL", "DDE", "NULL", (char *)NULL); result = TCL_ERROR; goto cleanup; @@ -1736,8 +1702,8 @@ DdeObjCmd( ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (serviceName == NULL) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("invalid service name \"\"", -1)); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "invalid service name \"\"", -1)); Tcl_SetErrorCode(interp, "TCL", "DDE", "NO_SERVER", (char *)NULL); result = TCL_ERROR; goto cleanup; @@ -1850,8 +1816,8 @@ DdeObjCmd( if (MakeDdeConnection(interp, serviceName, &hConv) != TCL_OK) { invalidServerResponse: - Tcl_SetObjResult(interp, - Tcl_NewStringObj("invalid data returned from server", -1)); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "invalid data returned from server", -1)); Tcl_SetErrorCode(interp, "TCL", "DDE", "BAD_RESPONSE", (char *)NULL); result = TCL_ERROR; goto cleanup; diff --git a/win/tclWinFCmd.c b/win/tclWinFCmd.c index a9173da..6147140 100644 --- a/win/tclWinFCmd.c +++ b/win/tclWinFCmd.c @@ -16,11 +16,12 @@ * The following constants specify the type of callback when * TraverseWinTree() calls the traverseProc() */ - -#define DOTREE_PRED 1 /* pre-order directory */ -#define DOTREE_POSTD 2 /* post-order directory */ -#define DOTREE_F 3 /* regular file */ -#define DOTREE_LINK 4 /* symbolic link */ +enum TclTraverseWinTreeTypes { + DOTREE_PRED = 1, /* pre-order directory */ + DOTREE_POSTD = 2, /* post-order directory */ + DOTREE_F = 3, /* regular file */ + DOTREE_LINK = 4 /* symbolic link */ +}; /* * Callbacks for file attributes code. @@ -1132,7 +1133,6 @@ DoRemoveJustDirectory( } } return TCL_ERROR; - } static int @@ -1198,7 +1198,8 @@ TraverseWinTree( { DWORD sourceAttr; WCHAR *nativeSource, *nativeTarget, *nativeErrfile; - int result, found, sourceLen, targetLen = 0, oldSourceLen, oldTargetLen; + int result, found; + Tcl_Size sourceLen, oldSourceLen, oldTargetLen, targetLen = 0; HANDLE handle; WIN32_FIND_DATAW data; @@ -1273,7 +1274,7 @@ TraverseWinTree( found = 1; for (; found; found = FindNextFileW(handle, &data)) { WCHAR *nativeName; - int len; + size_t len; WCHAR *wp = data.cFileName; if (*wp == '.') { @@ -1988,7 +1989,7 @@ TclpCreateTemporaryDirectory( Tcl_Obj *basenameObj) { Tcl_DString base, name; /* Contains WCHARs */ - int baseLen; + Tcl_Size baseLen; DWORD error; WCHAR tempBuf[MAX_PATH + 1]; DWORD len = GetTempPathW(MAX_PATH, tempBuf); diff --git a/win/tclWinFile.c b/win/tclWinFile.c index c520478..6cb9968 100644 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -380,7 +380,7 @@ WinSymLinkDirectory( { DUMMY_REPARSE_BUFFER dummy; REPARSE_DATA_BUFFER *reparseBuffer = (REPARSE_DATA_BUFFER *) &dummy; - int len; + size_t len; WCHAR nativeTarget[MAX_PATH]; WCHAR *loop; @@ -390,7 +390,7 @@ WinSymLinkDirectory( memcpy(nativeTarget, L"\\??\\", 4 * sizeof(WCHAR)); memcpy(nativeTarget + 4, linkTargetPath, - sizeof(WCHAR) * (1+wcslen((WCHAR *) linkTargetPath))); + sizeof(WCHAR) * (1+wcslen((WCHAR *) linkTargetPath))); len = wcslen(nativeTarget); /* @@ -415,7 +415,7 @@ WinSymLinkDirectory( memset(reparseBuffer, 0, sizeof(DUMMY_REPARSE_BUFFER)); reparseBuffer->ReparseTag = IO_REPARSE_TAG_MOUNT_POINT; reparseBuffer->MountPointReparseBuffer.SubstituteNameLength = - wcslen(nativeTarget) * sizeof(WCHAR); + (WORD)(wcslen(nativeTarget) * sizeof(WCHAR)); reparseBuffer->Reserved = 0; reparseBuffer->MountPointReparseBuffer.PrintNameLength = 0; reparseBuffer->MountPointReparseBuffer.PrintNameOffset = @@ -545,7 +545,8 @@ static Tcl_Obj * WinReadLinkDirectory( const WCHAR *linkDirPath) { - int attr, len, offset; + int attr, offset; + Tcl_Size len; DUMMY_REPARSE_BUFFER dummy; REPARSE_DATA_BUFFER *reparseBuffer = (REPARSE_DATA_BUFFER *) &dummy; Tcl_Obj *retVal; @@ -1433,7 +1434,7 @@ TclpGetUserHome( char *result = NULL; USER_INFO_1 *uiPtr; Tcl_DString ds; - int nameLen = -1; + Tcl_Size nameLen = -1; int rc = 0; const char *domain; WCHAR *wName, *wHomeDir, *wDomain; @@ -1756,9 +1757,9 @@ NativeAccess( * go). */ - if(!GetSecurityDescriptorOwner(sdPtr,&pSid,&SidDefaulted) || - memcmp(GetSidIdentifierAuthority(pSid),&samba_unmapped, - sizeof(SID_IDENTIFIER_AUTHORITY))==0) { + if (!GetSecurityDescriptorOwner(sdPtr,&pSid,&SidDefaulted) || + memcmp(GetSidIdentifierAuthority(pSid),&samba_unmapped, + sizeof(SID_IDENTIFIER_AUTHORITY))==0) { HeapFree(GetProcessHeap(), 0, sdPtr); return 0; /* Attrib tests say access allowed. */ } @@ -1862,7 +1863,7 @@ static int NativeIsExec( const WCHAR *path) { - int len = wcslen(path); + size_t len = wcslen(path); if (len < 5) { return 0; @@ -2141,17 +2142,17 @@ NativeStat( dev = NativeDev(nativePath); mode = NativeStatMode(attr, checkLinks, NativeIsExec(nativePath)); if (fileType == FILE_TYPE_CHAR) { - mode &= ~S_IFMT; + mode &= (unsigned short)~S_IFMT; mode |= S_IFCHR; } else if (fileType == FILE_TYPE_DISK) { - mode &= ~S_IFMT; + mode &= (unsigned short)~S_IFMT; mode |= S_IFBLK; } statPtr->st_dev = (dev_t) dev; - statPtr->st_ino = inode; + statPtr->st_ino = (_ino_t)inode; statPtr->st_mode = mode; - statPtr->st_nlink = nlink; + statPtr->st_nlink = (short)nlink; statPtr->st_uid = 0; statPtr->st_gid = 0; statPtr->st_rdev = (dev_t) dev; @@ -2530,9 +2531,9 @@ TclpFilesystemPathType( int TclpObjNormalizePath( TCL_UNUSED(Tcl_Interp *), - Tcl_Obj *pathPtr, /* An unshared object containing the path to + Tcl_Obj *pathPtr, /* An unshared object containing the path to * normalize */ - int nextCheckpoint) /* offset to start at in pathPtr */ + int nextCheckpoint1) /* offset to start at in pathPtr */ { char *lastValidPathEnd = NULL; Tcl_DString dsNorm; /* This will hold the normalized string. */ @@ -2540,6 +2541,7 @@ TclpObjNormalizePath( Tcl_Obj *temp = NULL; int isDrive = 1; Tcl_DString ds; /* Some workspace. */ + Tcl_Size nextCheckpoint = nextCheckpoint1; Tcl_DStringInit(&dsNorm); path = TclGetString(pathPtr); @@ -2693,7 +2695,7 @@ TclpObjNormalizePath( } } if (checkDots != NULL) { - int dotLen = currentPathEndPosition-lastValidPathEnd; + Tcl_Size dotLen = currentPathEndPosition-lastValidPathEnd; /* * Path is just dots. We shouldn't really ever see a path @@ -2832,7 +2834,7 @@ TclpObjNormalizePath( Tcl_DecrRefCount(temp); } - return nextCheckpoint; + return (int)nextCheckpoint; } /* @@ -3103,7 +3105,7 @@ TclNativeCreateNativeRep( goto done; } MultiByteToWideChar(CP_UTF8, MB_ERR_INVALID_CHARS, str, -1, nativePathPtr, - len + 2); + (DWORD)len + 2); nativePathPtr[len] = 0; /* diff --git a/win/tclWinNotify.c b/win/tclWinNotify.c index 2c93a41..f106345 100644 --- a/win/tclWinNotify.c +++ b/win/tclWinNotify.c @@ -19,8 +19,11 @@ #define INTERVAL_TIMER 1 /* Handle of interval timer. */ -#define WM_WAKEUP WM_USER /* Message that is send by +enum TclWinNotifyMessages { + WM_WAKEUP = WM_USER /* Message that is send by * Tcl_AlertNotifier. */ +}; + /* * The following static structure contains the state information for the * Windows implementation of the Tcl notifier. One of these structures is @@ -148,7 +151,7 @@ TclpInitNotifier(void) void TclpFinalizeNotifier( - void *clientData) /* Pointer to notifier data. */ + void *clientData) /* Pointer to notifier data. */ { ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData; @@ -218,7 +221,7 @@ TclpFinalizeNotifier( void TclpAlertNotifier( - void *clientData) /* Pointer to thread data. */ + void *clientData) /* Pointer to thread data. */ { ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData; @@ -264,7 +267,7 @@ TclpAlertNotifier( void TclpSetTimer( - const Tcl_Time *timePtr) /* Maximum block time, or NULL. */ + const Tcl_Time *timePtr) /* Maximum block time, or NULL. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); UINT timeout; @@ -464,7 +467,7 @@ TclpNotifierData(void) int TclpWaitForEvent( - const Tcl_Time *timePtr) /* Maximum block time, or NULL. */ + const Tcl_Time *timePtr) /* Maximum block time, or NULL. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); MSG msg; diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c index 71d1e4b..1c6d302 100644 --- a/win/tclWinPipe.c +++ b/win/tclWinPipe.c @@ -28,22 +28,24 @@ static int initialized = 0; TCL_DECLARE_MUTEX(pipeMutex) /* - * The following defines identify the various types of applications that run - * under windows. There is special case code for the various types. + * The following values identify the various types of applications that run + * under Windows. There is special case code for the various types. */ - -#define APPL_NONE 0 -#define APPL_DOS 1 -#define APPL_WIN3X 2 -#define APPL_WIN32 3 +enum TclWinApplicationTypes { + APPL_NONE = 0, + APPL_DOS = 1, + APPL_WIN3X = 2, + APPL_WIN32 = 3 +}; /* * The following constants and structures are used to encapsulate the state of * various types of files used in a pipeline. This used to have a 1 && 2 that * supported Win32s. */ - -#define WIN_FILE 3 /* Basic Win32 file. */ +enum PipeStageIds { + WIN_FILE = 3 /* Basic Win32 file. */ +}; /* * This structure encapsulates the common state associated with all file types @@ -68,18 +70,14 @@ typedef struct ProcInfo { static ProcInfo *procList; /* - * Bit masks used in the flags field of the PipeInfo structure below. + * Bit masks used in the flags/readFlags fields of the PipeInfo structure below. */ - -#define PIPE_PENDING (1<<0) /* Message is pending in the queue. */ -#define PIPE_ASYNC (1<<1) /* Channel is non-blocking. */ - -/* - * Bit masks used in the sharedFlags field of the PipeInfo structure below. - */ - -#define PIPE_EOF (1<<2) /* Pipe has reached EOF. */ -#define PIPE_EXTRABYTE (1<<3) /* The reader thread has consumed one byte. */ +enum TclWinPipeInfoFlags { + PIPE_PENDING = 1<<0, /* Message is pending in the queue. */ + PIPE_ASYNC = 1<<1, /* Channel is non-blocking. */ + PIPE_EOF = 1<<2, /* Pipe has reached EOF. */ + PIPE_EXTRABYTE = 1<<3 /* The reader thread has consumed one byte. */ +}; /* * TODO: It appears the whole EXTRABYTE machinery is in place to support @@ -133,7 +131,7 @@ typedef struct PipeInfo { * synchronized with the writable object. */ int readFlags; /* Flags that are shared with the reader * thread. Access is synchronized with the - * readable object. */ + * readable object. */ char extraByte; /* Buffer for extra character consumed by * reader thread. This byte is shared with the * reader thread so access must be @@ -671,16 +669,18 @@ TclpCreateTempFile( */ if (contents != NULL) { - DWORD result, length; + DWORD result; + Tcl_Size length; const char *p; - int toCopy; + Tcl_Size toCopy; /* * Convert the contents from UTF to native encoding */ - if (Tcl_UtfToExternalDStringEx(NULL, NULL, contents, TCL_INDEX_NONE, 0, &dstring, NULL) != TCL_OK) { - goto error; + if (Tcl_UtfToExternalDStringEx(NULL, NULL, contents, TCL_INDEX_NONE, 0, + &dstring, NULL) != TCL_OK) { + goto error; } native = Tcl_DStringValue(&dstring); @@ -689,7 +689,7 @@ TclpCreateTempFile( if (*p == '\n') { length = p - native; if (length > 0) { - if (!WriteFile(handle, native, length, &result, NULL)) { + if (!WriteFile(handle, native, (DWORD)length, &result, NULL)) { goto error; } } @@ -701,7 +701,7 @@ TclpCreateTempFile( } length = p - native; if (length > 0) { - if (!WriteFile(handle, native, length, &result, NULL)) { + if (!WriteFile(handle, native, (DWORD)length, &result, NULL)) { goto error; } } @@ -916,7 +916,7 @@ TclpCreateProcess( * occurred when creating the child process. * Error messages from the child process * itself are sent to errorFile. */ - size_t argc, /* Number of arguments in following array. */ + size_t argc, /* Number of arguments in following array. */ const char **argv, /* Array of argument strings. argv[0] contains * the name of the executable converted to * native format (using the @@ -1262,7 +1262,8 @@ ApplicationType( char fullName[]) /* Filled with complete path to * application. */ { - int applType, i, nameLen, found; + int applType, i, found; + Tcl_Size nameLen; HANDLE hFile; WCHAR *rest; char *ext; @@ -1552,7 +1553,7 @@ static void BuildCommandLine( const char *executable, /* Full path of executable (including * extension). Replacement for argv[0]. */ - size_t argc, /* Number of arguments. */ + size_t argc, /* Number of arguments. */ const char **argv, /* Argument strings in UTF. */ Tcl_DString *linePtr) /* Initialized Tcl_DString that receives the * command line (WCHAR). */ @@ -1967,7 +1968,7 @@ TclGetAndDetachPids( static int PipeBlockModeProc( - void *instanceData, /* Instance data for channel. */ + void *instanceData, /* Instance data for channel. */ int mode) /* TCL_MODE_BLOCKING or * TCL_MODE_NONBLOCKING. */ { @@ -2006,7 +2007,7 @@ PipeBlockModeProc( static int PipeClose2Proc( - void *instanceData, /* Pointer to PipeInfo structure. */ + void *instanceData, /* Pointer to PipeInfo structure. */ Tcl_Interp *interp, /* For error reporting. */ int flags) /* Flags that indicate which side to close. */ { @@ -2177,7 +2178,7 @@ PipeClose2Proc( static int PipeInputProc( - void *instanceData, /* Pipe state. */ + void *instanceData, /* Pipe state. */ char *buf, /* Where to store data read. */ int bufSize, /* How much space is available in the * buffer? */ @@ -2271,7 +2272,7 @@ PipeInputProc( static int PipeOutputProc( - void *instanceData, /* Pipe state. */ + void *instanceData, /* Pipe state. */ const char *buf, /* The data buffer. */ int toWrite, /* How many bytes to write? */ int *errorCode) /* Where to store error code. */ @@ -2345,7 +2346,6 @@ PipeOutputProc( error: *errorCode = errno; return -1; - } /* @@ -2453,7 +2453,7 @@ PipeEventProc( static void PipeWatchProc( - void *instanceData, /* Pipe state. */ + void *instanceData, /* Pipe state. */ int mask) /* What events to watch for, OR-ed combination * of TCL_READABLE, TCL_WRITABLE and * TCL_EXCEPTION. */ @@ -2515,9 +2515,9 @@ PipeWatchProc( static int PipeGetHandleProc( - void *instanceData, /* The pipe state. */ + void *instanceData, /* The pipe state. */ int direction, /* TCL_READABLE or TCL_WRITABLE */ - void **handlePtr) /* Where to store the handle. */ + void **handlePtr) /* Where to store the handle. */ { PipeInfo *infoPtr = (PipeInfo *) instanceData; WinFile *filePtr; @@ -2583,7 +2583,7 @@ Tcl_WaitPid( prevPtrPtr = &procList; for (infoPtr = procList; infoPtr != NULL; prevPtrPtr = &infoPtr->nextPtr, infoPtr = infoPtr->nextPtr) { - if (infoPtr->dwProcessId == (Tcl_Size)pid) { + if (infoPtr->dwProcessId == (Tcl_Size)pid) { *prevPtrPtr = infoPtr->nextPtr; break; } @@ -2734,7 +2734,7 @@ TclWinAddProcess( PipeInit(); procPtr->hProcess = hProcess; - procPtr->dwProcessId = id; + procPtr->dwProcessId = (int)id; Tcl_MutexLock(&pipeMutex); procPtr->nextPtr = procList; procList = procPtr; @@ -2941,7 +2941,7 @@ PipeReaderThread( LPVOID arg) { TclPipeThreadInfo *pipeTI = (TclPipeThreadInfo *) arg; - PipeInfo *infoPtr = NULL; /* access info only after success init/wait */ + PipeInfo *infoPtr = NULL; /* access info only after success init/wait */ HANDLE handle = NULL; DWORD count, err; int done = 0; @@ -3064,7 +3064,7 @@ PipeWriterThread( LPVOID arg) { TclPipeThreadInfo *pipeTI = (TclPipeThreadInfo *)arg; - PipeInfo *infoPtr = NULL; /* access info only after success init/wait */ + PipeInfo *infoPtr = NULL; /* access info only after success init/wait */ HANDLE handle = NULL; DWORD count, toWrite; char *buf; @@ -3244,7 +3244,7 @@ TclpOpenTemporaryFile( memcpy(namePtr, baseStr, length); namePtr += length; } - counter = TclpGetClicks() % 65533; + counter = (int)(TclpGetClicks() % 65533); counter2 = 1024; /* Only try this many times! Prevents * an infinite loop. */ diff --git a/win/tclWinPort.h b/win/tclWinPort.h index afb76df..decadd4 100644 --- a/win/tclWinPort.h +++ b/win/tclWinPort.h @@ -513,12 +513,12 @@ typedef DWORD_PTR * PDWORD_PTR; * use by tclAlloc.c. */ -#define TclpSysAlloc(size) ((void*)HeapAlloc(GetProcessHeap(), \ - 0, size)) -#define TclpSysFree(ptr) (HeapFree(GetProcessHeap(), \ - 0, (HGLOBAL)ptr)) -#define TclpSysRealloc(ptr, size) ((void*)HeapReAlloc(GetProcessHeap(), \ - 0, (LPVOID)ptr, size)) +#define TclpSysAlloc(size) \ + ((void*)HeapAlloc(GetProcessHeap(), 0, size)) +#define TclpSysFree(ptr) \ + (HeapFree(GetProcessHeap(), 0, (HGLOBAL)ptr)) +#define TclpSysRealloc(ptr, size) \ + ((void*)HeapReAlloc(GetProcessHeap(), 0, (LPVOID)ptr, size)) /* This type is not defined in the Windows headers */ #define socklen_t int diff --git a/win/tclWinReg.c b/win/tclWinReg.c index 493d28d..02b58d8 100644 --- a/win/tclWinReg.c +++ b/win/tclWinReg.c @@ -87,22 +87,6 @@ static const char *const typeNames[] = { static DWORD lastType = REG_RESOURCE_LIST; -#if (TCL_MAJOR_VERSION < 9) && defined(TCL_MINOR_VERSION) && (TCL_MINOR_VERSION < 7) -# if TCL_UTF_MAX > 3 -# define Tcl_WCharToUtfDString(a,b,c) Tcl_WinTCharToUtf((TCHAR *)(a),(b)*sizeof(WCHAR),c) -# define Tcl_UtfToWCharDString(a,b,c) (WCHAR *)Tcl_WinUtfToTChar(a,b,c) -# else -# define Tcl_WCharToUtfDString Tcl_UniCharToUtfDString -# define Tcl_UtfToWCharDString Tcl_UtfToUniCharDString -# endif -#ifndef Tcl_Size -# define Tcl_Size int -#endif -#ifndef Tcl_CreateObjCommand2 -# define Tcl_CreateObjCommand2 Tcl_CreateObjCommand -#endif -#endif - /* * Declarations for functions defined in this file. */ @@ -146,11 +130,6 @@ extern "C" { #endif DLLEXPORT int Registry_Init(Tcl_Interp *interp); DLLEXPORT int Registry_Unload(Tcl_Interp *interp, int flags); -#if TCL_MAJOR_VERSION < 9 -/* With those additional entries, "load tclregistry13.dll" works without 3th argument */ -DLLEXPORT int Tclregistry_Init(Tcl_Interp *interp); -DLLEXPORT int Tclregistry_Unload(Tcl_Interp *interp, int flags); -#endif #ifdef __cplusplus } #endif @@ -177,23 +156,15 @@ Registry_Init( { Tcl_Command cmd; - if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) { + if (Tcl_InitStubs(interp, "9.0-", 0) == NULL) { return TCL_ERROR; } cmd = Tcl_CreateObjCommand2(interp, "registry", RegistryObjCmd, interp, DeleteCmd); Tcl_SetAssocData(interp, REGISTRY_ASSOC_KEY, NULL, cmd); - return Tcl_PkgProvideEx(interp, "registry", "1.3.7", NULL); + return Tcl_PkgProvideEx(interp, "registry", "1.4a1", NULL); } -#if TCL_MAJOR_VERSION < 9 -int -Tclregistry_Init( - Tcl_Interp *interp) -{ - return Registry_Init(interp); -} -#endif /* *---------------------------------------------------------------------- @@ -240,15 +211,6 @@ Registry_Unload( return TCL_OK; } -#if TCL_MAJOR_VERSION < 9 -int -Tclregistry_Unload( - Tcl_Interp *interp, - int flags) -{ - return Registry_Unload(interp, flags); -} -#endif /* *---------------------------------------------------------------------- @@ -465,8 +427,8 @@ DeleteKey( } if (*keyName == '\0') { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("bad key: cannot delete root keys", -1)); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "bad key: cannot delete root keys", -1)); Tcl_SetErrorCode(interp, "WIN_REG", "DEL_ROOT_KEY", (char *)NULL); Tcl_Free(buffer); return TCL_ERROR; @@ -487,8 +449,8 @@ DeleteKey( if (result == ERROR_FILE_NOT_FOUND) { return TCL_OK; } - Tcl_SetObjResult(interp, - Tcl_NewStringObj("unable to delete key: ", -1)); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "unable to delete key: ", -1)); AppendSystemError(interp, result); return TCL_ERROR; } @@ -503,8 +465,8 @@ DeleteKey( Tcl_DStringFree(&buf); if (result != ERROR_SUCCESS && result != ERROR_FILE_NOT_FOUND) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("unable to delete key: ", -1)); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "unable to delete key: ", -1)); AppendSystemError(interp, result); result = TCL_ERROR; } else { @@ -998,8 +960,8 @@ OpenKey( if (result == TCL_OK) { result = OpenSubKey(hostName, rootKey, keyName, mode, flags, keyPtr); if (result != ERROR_SUCCESS) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("unable to open key: ", -1)); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "unable to open key: ", -1)); AppendSystemError(interp, result); result = TCL_ERROR; } else { @@ -1207,12 +1169,6 @@ RecursiveDeleteKey( Tcl_DString subkey; HKEY hKey; REGSAM saveMode = mode; - static int checkExProc = 0; - typedef LONG (* regDeleteKeyExProc) (HKEY, LPCWSTR, REGSAM, DWORD); - static regDeleteKeyExProc regDeleteKeyEx = (regDeleteKeyExProc) NULL; - /* Really RegDeleteKeyExW() but that's not - * available on all versions of Windows - * supported by Tcl. */ /* * Do not allow NULL or empty key name. @@ -1241,22 +1197,8 @@ RecursiveDeleteKey( result = RegEnumKeyExW(hKey, 0, (WCHAR *)Tcl_DStringValue(&subkey), &size, NULL, NULL, NULL, NULL); if (result == ERROR_NO_MORE_ITEMS) { - /* - * RegDeleteKeyEx doesn't exist on non-64bit XP platforms, so we - * can't compile with it in. We need to check for it at runtime - * and use it if we find it. - */ - - if (mode && !checkExProc) { - HMODULE handle; - - checkExProc = 1; - handle = GetModuleHandleW(L"ADVAPI32"); - regDeleteKeyEx = (regDeleteKeyExProc) (void *) - GetProcAddress(handle, "RegDeleteKeyExW"); - } - if (mode && regDeleteKeyEx) { - result = regDeleteKeyEx(startKey, keyName, mode, 0); + if (mode) { + result = RegDeleteKeyExW(startKey, keyName, mode, 0); } else { result = RegDeleteKeyW(startKey, keyName); } @@ -1406,8 +1348,8 @@ SetValue( RegCloseKey(key); if (result != ERROR_SUCCESS) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("unable to set value: ", -1)); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "unable to set value: ", -1)); AppendSystemError(interp, result); return TCL_ERROR; } diff --git a/win/tclWinSerial.c b/win/tclWinSerial.c index 48baaa8..890dd8e 100644 --- a/win/tclWinSerial.c +++ b/win/tclWinSerial.c @@ -1794,7 +1794,7 @@ SerialSetOptionProc( dcb.XoffChar = argv[1][0]; if (argv[0][0] & 0x80 || argv[1][0] & 0x80) { Tcl_UniChar character = 0; - int charLen; + Tcl_Size charLen; charLen = TclUtfToUniChar(argv[0], &character); if ((character > 0xFF) || argv[0][charLen]) { diff --git a/win/tclWinSock.c b/win/tclWinSock.c index 2784962..5b7abb1 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -318,35 +318,6 @@ SendSelectMessage( } /* - * Address print debug functions - */ -#if 0 -static inline void -printaddrinfo( - struct addrinfo *ai, - char *prefix) -{ - char host[NI_MAXHOST], port[NI_MAXSERV]; - - getnameinfo(ai->ai_addr, ai->ai_addrlen, - host, sizeof(host), port, sizeof(port), - NI_NUMERICHOST | NI_NUMERICSERV); -} - -static void -printaddrinfolist( - struct addrinfo *addrlist, - char *prefix) -{ - struct addrinfo *ai; - - for (ai = addrlist; ai != NULL; ai = ai->ai_next) { - printaddrinfo(ai, prefix); - } -} -#endif - -/* *---------------------------------------------------------------------- * * InitializeHostName -- @@ -392,7 +363,7 @@ InitializeHostName( Tcl_DStringInit(&ds); Tcl_DStringSetLength(&ds, 256); - gethostname(Tcl_DStringValue(&ds), Tcl_DStringLength(&ds)); + gethostname(Tcl_DStringValue(&ds), (int)Tcl_DStringLength(&ds)); Tcl_DStringSetLength(&ds, strlen(Tcl_DStringValue(&ds))); } @@ -1762,7 +1733,7 @@ TcpConnect( */ if (bind(statePtr->sockets->fd, statePtr->myaddr->ai_addr, - statePtr->myaddr->ai_addrlen) == SOCKET_ERROR) { + (socklen_t)statePtr->myaddr->ai_addrlen) == SOCKET_ERROR) { Tcl_WinConvertError((DWORD) WSAGetLastError()); continue; } @@ -1831,7 +1802,7 @@ TcpConnect( */ connect(statePtr->sockets->fd, statePtr->addr->ai_addr, - statePtr->addr->ai_addrlen); + (socklen_t)statePtr->addr->ai_addrlen); error = WSAGetLastError(); Tcl_WinConvertError(error); @@ -2218,7 +2189,7 @@ Tcl_OpenTcpServerEx( */ if (bind(sock, addrPtr->ai_addr, - addrPtr->ai_addrlen) == SOCKET_ERROR) { + (socklen_t)addrPtr->ai_addrlen) == SOCKET_ERROR) { Tcl_WinConvertError((DWORD) WSAGetLastError()); closesocket(sock); sock = INVALID_SOCKET; /* Bug [40b1814b93] */ @@ -3056,7 +3027,7 @@ SocketThread( SetEvent(tsdPtr->readyEvent); - return msg.wParam; + return (DWORD)msg.wParam; } /* diff --git a/win/tclWinTest.c b/win/tclWinTest.c index 005fb37..ad82d0a 100644 --- a/win/tclWinTest.c +++ b/win/tclWinTest.c @@ -477,7 +477,7 @@ TestplatformChmod( * Always include DACL modify rights so we don't get locked out */ aceEntry[nSids].mask = READ_CONTROL | WRITE_DAC | WRITE_OWNER | SYNCHRONIZE | - FILE_READ_ATTRIBUTES | FILE_WRITE_ATTRIBUTES; + FILE_READ_ATTRIBUTES | FILE_WRITE_ATTRIBUTES; if (pmode & 0700) { /* Owner permissions. Assumes current process is owner */ if (pmode & 0400) { @@ -510,7 +510,8 @@ TestplatformChmod( } aceEntry[nSids].sidLen = GetLengthSid(pTokenGroup->PrimaryGroup); aceEntry[nSids].pSid = (PSID)Tcl_Alloc(aceEntry[nSids].sidLen); - if (!CopySid(aceEntry[nSids].sidLen, aceEntry[nSids].pSid, pTokenGroup->PrimaryGroup)) { + if (!CopySid(aceEntry[nSids].sidLen, aceEntry[nSids].pSid, + pTokenGroup->PrimaryGroup)) { Tcl_Free(pTokenGroup); Tcl_Free(aceEntry[nSids].pSid); /* Since we have not ++'ed nSids */ goto done; @@ -568,7 +569,7 @@ TestplatformChmod( /* Add in size required for each ACE entry in the ACL */ for (i = 0; i < nSids; ++i) { newAclSize += - offsetof(ACCESS_ALLOWED_ACE, SidStart) + aceEntry[i].sidLen; + (DWORD)offsetof(ACCESS_ALLOWED_ACE, SidStart) + aceEntry[i].sidLen; } newAcl = (PACL)Tcl_Alloc(newAclSize); if (!InitializeAcl(newAcl, newAclSize, ACL_REVISION)) { diff --git a/win/tclWinThrd.c b/win/tclWinThrd.c index 13ec5f4..a483235 100644 --- a/win/tclWinThrd.c +++ b/win/tclWinThrd.c @@ -216,8 +216,8 @@ TclpThreadCreate( EnterCriticalSection(&joinLock); - *idPtr = 0; /* must initialize as Tcl_Thread is a pointer and - * on WIN64 sizeof void* != sizeof unsigned */ + *idPtr = 0; /* must initialize as Tcl_Thread is a pointer and + * on WIN64 sizeof void* != sizeof unsigned */ #if defined(_MSC_VER) || defined(__MSVCRT__) tHandle = (HANDLE) _beginthreadex(NULL, (unsigned)stackSize, |