summaryrefslogtreecommitdiffstats
path: root/Tests/FindPython/Python3Module
ModeNameSize
-rw-r--r--CMakeLists.txt1524logstatsplain
generated by cgit v0.12 at 2025-12-29 19:15:02 (GMT)
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/). ### 2a. Unix Documentation The `doc` subdirectory in this release contains a complete set of diff --git a/changes.md b/changes.md index 806afa7..f8931e7 100644 --- a/changes.md +++ b/changes.md @@ -18,180 +18,11 @@ to the userbase. # Updated bundled packages, libraries, standards, data - sqlite3 3.48.0 -Release Tcl 9.0.1 arises from the check-in with tag `core-9-0-1`. +Release Tcl 9.1a0 arises from the check-in with tag `core-9-1-a0`. -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 Features - -## 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 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 - -## Numbers - - 0NNN format is no longer octal interpretation. Use 0oNNN. - - 0dNNNN format to compel decimal interpretation. - - NN_NNN_NNN, underscores in numbers for optional readability - - Functions: `isinf()`, `isnan()`, `isnormal()`, `issubnormal()`, `isunordered()` - - Command: `fpclassify` - - Function `int()` no longer truncates to word size - -## TclOO facilities - - private variables and methods - - class variables and methods - - abstract and singleton classes - - configurable properties - - `method -export`, `method -unexport` -# 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/bc4ac0) diff --git a/doc/Hash.3 b/doc/Hash.3 index e4567a5..09f6a04 100644 --- a/doc/Hash.3 +++ b/doc/Hash.3 @@ -276,7 +276,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/generic/tcl.decls b/generic/tcl.decls index 2ab1f7f..78f61ec 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) } @@ -1217,7 +1202,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 @@ -1324,16 +1309,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 { @@ -2144,7 +2129,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) diff --git a/generic/tcl.h b/generic/tcl.h index ae1e30d..8153e32 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 2 - -# define TCL_VERSION "9.0" -# define TCL_PATCH_LEVEL "9.0.2" -#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 0 + +#define TCL_VERSION "9.1" +#define TCL_PATCH_LEVEL "9.1a0" #if defined(RC_INVOKED) /* @@ -321,24 +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 - typedef int Tcl_Size; -# define TCL_SIZE_MAX ((int)(((unsigned int)-1)>>1)) -# define TCL_SIZE_MODIFIER "" -#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; @@ -463,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; /* @@ -583,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, @@ -594,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, ...); @@ -667,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 */ @@ -691,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 @@ -848,8 +813,13 @@ typedef struct { * Tcl_CreateObjCommand; 2 if objProc was registered by * a call to Tcl_CreateObjCommand2; 0 otherwise. * Tcl_SetCmdInfo does not modify this field. */ +#ifdef TCL_NO_DEPRECATED + void *objProcNotUsed; /* Command's object-based function. */ + void *objClientDataNotUsed; /* ClientData for object proc. */ +#else Tcl_ObjCmdProc *objProc; /* Command's object-based function. */ void *objClientData; /* ClientData for object proc. */ +#endif Tcl_CmdProc *proc; /* Command's string-based function. */ void *clientData; /* ClientData for string proc. */ Tcl_CmdDeleteProc *deleteProc; @@ -951,11 +921,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. @@ -1060,18 +1026,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); @@ -1189,15 +1151,10 @@ 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 @@ -1259,7 +1216,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; @@ -1315,12 +1272,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. */ @@ -1371,11 +1324,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. @@ -1923,12 +1872,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. @@ -1947,9 +1894,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 @@ -2030,11 +1974,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 */ @@ -2044,7 +1984,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 @@ -2087,11 +2027,7 @@ typedef struct Tcl_EncodingType { */ #ifndef TCL_UTF_MAX -# if TCL_MAJOR_VERSION > 8 -# define TCL_UTF_MAX 4 -# else -# define TCL_UTF_MAX 3 -# endif +# define TCL_UTF_MAX 4 #endif /* @@ -2140,11 +2076,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 /* @@ -2301,11 +2233,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 @@ -2327,43 +2255,14 @@ void * TclStubCall(void *arg); #endif #ifdef USE_TCL_STUBS -#if TCL_MAJOR_VERSION < 9 -# if TCL_UTF_MAX < 4 # 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, "8.7b1", \ - (exact)|(TCL_MAJOR_VERSION<<8)|(0xFF<<16), \ - TCL_STUB_MAGIC) -# endif -#elif TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE -# define Tcl_InitStubs(interp, version, exact) \ - (Tcl_InitStubs)(interp, version, \ - (exact)|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16), \ - TCL_STUB_MAGIC) -#else -# define Tcl_InitStubs(interp, version, exact) \ - (Tcl_InitStubs)(interp, (((exact)&1) ? (version) : "9.0.0"), \ (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")) -#elif TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE # define Tcl_InitStubs(interp, version, exact) \ Tcl_PkgInitStubsCheck(interp, version, \ (exact)|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16)) -#else -# define Tcl_InitStubs(interp, version, exact) \ - Tcl_PkgInitStubsCheck(interp, TCL_PATCH_LEVEL, \ - 1|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16)) -#endif #endif /* @@ -2405,7 +2304,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() \ diff --git a/generic/tclClock.c b/generic/tclClock.c index 85529b5..31e12e4 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -4664,11 +4664,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/tclCompile.h b/generic/tclCompile.h index 0a9f2a3..928a29a 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -135,7 +135,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_JUMP4 instructions * issued by the [break]s that we must * update. Note that resizing a jump (via * TclFixupForwardJump) can cause the contents @@ -145,7 +145,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; + size_t *continueTargets; /* The offsets of the INST_JUMP4 instructions * issued by the [continue]s that we must * update. Note that resizing a jump (via @@ -223,7 +223,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 +320,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 +337,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 +349,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]; @@ -1072,7 +1062,6 @@ typedef struct { *---------------------------------------------------------------- */ -#if TCL_MAJOR_VERSION > 8 MODULE_SCOPE Tcl_ObjCmdProc TclNRInterpCoroutine; /* @@ -1212,7 +1201,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 */ /* *---------------------------------------------------------------- diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 67d4108..487d524 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 */ @@ -1036,7 +1029,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); @@ -1122,14 +1115,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, @@ -1711,7 +1704,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); @@ -1889,12 +1882,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 */ @@ -1917,9 +1910,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); @@ -1967,7 +1960,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 */ @@ -2279,7 +2272,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 */ @@ -2314,10 +2307,10 @@ typedef struct TclStubs { 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 */ @@ -2523,7 +2516,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 */ @@ -2651,12 +2644,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 \ @@ -2740,8 +2730,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 \ @@ -3980,23 +3969,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 @@ -4049,26 +4021,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 @@ -4165,11 +4133,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 @@ -4193,55 +4157,7 @@ extern const TclStubs *tclStubsPtr; #undef TclParseArgsObjv #undef TclGetAliasObj -#if TCL_MAJOR_VERSION < 9 - /* TIP #627 for 8.7 */ -# 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 for 8.7 */ -# 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)) -#elif defined(TCL_8_API) -# undef Tcl_GetByteArrayFromObj +#if defined(TCL_8_API) # undef Tcl_GetBytesFromObj # undef Tcl_GetStringFromObj # undef Tcl_GetUnicodeFromObj @@ -4254,9 +4170,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))) @@ -4291,9 +4204,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))) @@ -4328,10 +4238,8 @@ 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)) #endif /* _TCLDECLS */ diff --git a/generic/tclIO.h b/generic/tclIO.h index 1077e09..06e49a5 100644 --- a/generic/tclIO.h +++ b/generic/tclIO.h @@ -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/tclInt.decls b/generic/tclInt.decls index 17cad13..7e5702c 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 963e850..49da289 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -218,10 +218,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; /* @@ -271,11 +269,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 @@ -974,9 +968,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. */ @@ -987,12 +978,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 @@ -1050,11 +1039,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 @@ -1098,7 +1083,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))) ? \ @@ -1200,7 +1184,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 @@ -1695,13 +1678,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; /* @@ -1995,20 +1978,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. @@ -2037,11 +2009,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. @@ -2065,9 +2032,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 @@ -2104,9 +2068,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. */ @@ -2770,20 +2731,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) \ @@ -2921,7 +2873,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 @@ -2943,7 +2895,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. */ @@ -3283,7 +3235,6 @@ struct Tcl_LoadHandle_ { *---------------------------------------------------------------- */ -#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, @@ -3558,10 +3509,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); @@ -3625,7 +3576,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); @@ -4074,7 +4025,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); @@ -4150,7 +4101,6 @@ 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 */ /* 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 85c8986..9f3b9f0 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 */ @@ -649,7 +648,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); @@ -661,7 +660,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); @@ -795,7 +794,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 */ 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/tclStubInit.c b/generic/tclStubInit.c index 9bfce36..6ecd8dc 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -850,9 +850,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 */ @@ -900,7 +900,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 */ diff --git a/library/init.tcl b/library/init.tcl index 2d8d0dd..02dbd67 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.2 +package require -exact tcl 9.1a0 # Compute the auto path to use in this interpreter. # The values on the path come from several locations: diff --git a/unix/Makefile.in b/unix/Makefile.in index b72b0da..cb7d258 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -2032,7 +2032,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 \ @@ -2040,14 +2039,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; \ @@ -2064,10 +2055,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 $$?; \ @@ -2079,11 +2066,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 \ @@ -2111,9 +2093,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; \ @@ -2124,17 +2103,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 diff --git a/unix/configure b/unix/configure index 589499e..bc06954 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=".2" +TCL_MINOR_VERSION=1 +TCL_PATCH_LEVEL="a0" VERSION=${TCL_VERSION} EXTRA_INSTALL_BINARIES=${EXTRA_INSTALL_BINARIES:-"@:"} @@ -11919,7 +11919,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 @@ -11978,7 +11978,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 67588cf..86aae29 100644 --- a/unix/configure.ac +++ b/unix/configure.ac @@ -3,7 +3,7 @@ dnl This file is an input file used by the GNU "autoconf" program to dnl generate the file "configure", which is run during Tcl installation dnl to configure the system for the local environment. -AC_INIT([tcl],[9.0]) +AC_INIT([tcl],[9.1]) AC_PREREQ([2.69]) dnl This is only used when included from macosx/configure.ac @@ -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=".2" +TCL_MINOR_VERSION=1 +TCL_PATCH_LEVEL="a0" VERSION=${TCL_VERSION} EXTRA_INSTALL_BINARIES=${EXTRA_INSTALL_BINARIES:-"@:"} diff --git a/unix/tcl.spec b/unix/tcl.spec index 68a75c7..f6aacf5 100644 --- a/unix/tcl.spec +++ b/unix/tcl.spec @@ -4,7 +4,7 @@ Name: tcl Summary: Tcl scripting language development environment -Version: 9.0.2 +Version: 9.1a0 Release: 2 License: BSD Group: Development/Languages diff --git a/win/Makefile.in b/win/Makefile.in index 3c6f03c..8624234 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -151,10 +151,8 @@ 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} @@ -534,7 +532,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 +607,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) @@ -880,10 +870,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 +880,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}"; \ diff --git a/win/configure b/win/configure index 801ff64..f476c0c 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,10 +2408,10 @@ 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=".2" +TCL_MINOR_VERSION=1 +TCL_PATCH_LEVEL="a0" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.4 @@ -6592,7 +6592,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 @@ -6647,7 +6647,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 630d204..1ca33ac 100644 --- a/win/configure.ac +++ b/win/configure.ac @@ -3,7 +3,7 @@ # 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]) @@ -12,10 +12,10 @@ AC_PREREQ([2.69]) # /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=".2" +TCL_MINOR_VERSION=1 +TCL_PATCH_LEVEL="a0" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.4 diff --git a/win/tcl.m4 b/win/tcl.m4 index a5b5a27..f4744b7 100644 --- a/win/tcl.m4 +++ b/win/tcl.m4 @@ -985,13 +985,13 @@ 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.0 binaries from DIR], + AC_ARG_WITH(tcl, [ --with-tcl=DIR use Tcl 9.1 binaries from DIR], TCL_BIN_DIR=$withval, TCL_BIN_DIR=`cd $TCL_BIN_DEFAULT; pwd`) if test ! -d $TCL_BIN_DIR; then AC_MSG_ERROR(Tcl directory $TCL_BIN_DIR does not exist) -- cgit v0.12 From 59f617f48fbc21c48617d12a3e82e29a6a30bffa Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 7 Jan 2025 13:07:16 +0000 Subject: Few more 9.0 -> 9.1 changes --- changes.md | 14 -------------- macosx/README | 4 ++-- unix/tcl.m4 | 12 ++++++------ win/README | 4 ++-- 4 files changed, 10 insertions(+), 24 deletions(-) diff --git a/changes.md b/changes.md index f8931e7..0a25efc 100644 --- a/changes.md +++ b/changes.md @@ -4,20 +4,6 @@ changes to the Tcl source code at > [Tcl Source Code](https://core.tcl-lang.org/tcl/timeline) -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. - -# Bug fixes - - Better error-message than "interpreter uses an incompatible stubs mechanism"](https://core.tcl-lang.org/tcl/tktview/fc3509) - -# Incompatibilities - - No known incompatibilities with the Tcl 9.0.0 public interface. - -# Updated bundled packages, libraries, standards, data - - sqlite3 3.48.0 - Release Tcl 9.1a0 arises from the check-in with tag `core-9-1-a0`. Highlighted differences between Tcl 9.1 and Tcl 9.0 are summarized below, diff --git a/macosx/README b/macosx/README index f5e3716..111184b 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, e.g. for a universal build on 10.9: CFLAGS="-arch x86_64 -arch arm64 -mmacosx-version-min=10.9" diff --git a/unix/tcl.m4 b/unix/tcl.m4 index 4265832..055f8c1 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/win/README b/win/README index 9b001ba..f596c9b 100644 --- a/win/README +++ b/win/README @@ -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 -- cgit v0.12 From 2cceaefd62ec11725a80874583f1cd0ca29cc1a2 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 7 Jan 2025 14:22:35 +0000 Subject: Don't build dltest for Tcl 8.x any more --- unix/dltest/Makefile.in | 40 ++-------------------------------------- 1 file changed, 2 insertions(+), 38 deletions(-) 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} -- cgit v0.12 From a5b5e3402681d610f7f47cf565447ab000836c4a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 8 Jan 2025 09:16:18 +0000 Subject: Superflouous TCL_NO_DEPRECATED usage (meant for TIP #626) --- generic/tcl.h | 5 ----- 1 file changed, 5 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index 8153e32..8d1e61d 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -813,13 +813,8 @@ typedef struct { * Tcl_CreateObjCommand; 2 if objProc was registered by * a call to Tcl_CreateObjCommand2; 0 otherwise. * Tcl_SetCmdInfo does not modify this field. */ -#ifdef TCL_NO_DEPRECATED - void *objProcNotUsed; /* Command's object-based function. */ - void *objClientDataNotUsed; /* ClientData for object proc. */ -#else Tcl_ObjCmdProc *objProc; /* Command's object-based function. */ void *objClientData; /* ClientData for object proc. */ -#endif Tcl_CmdProc *proc; /* Command's string-based function. */ void *clientData; /* ClientData for string proc. */ Tcl_CmdDeleteProc *deleteProc; -- cgit v0.12 From 681332c022e6ab5a1861d54c3e56e979c56796d9 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 10 Jan 2025 20:26:19 +0000 Subject: Tcl_GetAlias() should be handled by TCL_NO_DEPRECATED as well --- generic/tclDecls.h | 5 ++--- generic/tclStubInit.c | 3 --- 2 files changed, 2 insertions(+), 6 deletions(-) diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 347d047..f3bab5a 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -4326,6 +4326,8 @@ extern const TclStubs *tclStubsPtr; #undef Tcl_GlobalEval #define Tcl_GlobalEval(interp, objPtr) \ Tcl_EvalEx(interp, objPtr, TCL_INDEX_NONE, TCL_EVAL_GLOBAL) +#undef Tcl_GetAlias +#undef Tcl_SavedResult #undef Tcl_SaveResult #undef Tcl_RestoreResult #undef Tcl_DiscardResult @@ -4523,9 +4525,6 @@ extern const TclStubs *tclStubsPtr; * Deprecated Tcl procedures: */ -#ifdef TCL_NO_DEPRECATED -# undef Tcl_SavedResult -#endif /* TCL_NO_DEPRECATED */ #undef Tcl_EvalObj #define Tcl_EvalObj(interp, objPtr) \ Tcl_EvalObjEx(interp, objPtr, 0) diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index c879732..eabfda5 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -654,11 +654,8 @@ static int utfNcasecmp(const char *s1, const char *s2, unsigned int n){ # define Tcl_Eval 0 # undef Tcl_GlobalEval # define Tcl_GlobalEval 0 -# undef Tcl_SaveResult # define Tcl_SaveResult 0 -# undef Tcl_RestoreResult # define Tcl_RestoreResult 0 -# undef Tcl_DiscardResult # define Tcl_DiscardResult 0 # undef Tcl_SetResult # define Tcl_SetResult 0 -- cgit v0.12 From 7ab0b63abde4415990e4d66917a1af72e96b1bd9 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 10 Jan 2025 20:41:49 +0000 Subject: Tcl_MakeSafe() should be handled by TCL_NO_DEPRECATED as well --- generic/tclDecls.h | 1 + 1 file changed, 1 insertion(+) diff --git a/generic/tclDecls.h b/generic/tclDecls.h index f3bab5a..43857fa 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -4332,6 +4332,7 @@ extern const TclStubs *tclStubsPtr; #undef Tcl_RestoreResult #undef Tcl_DiscardResult #undef Tcl_SetResult +#undef Tcl_MakeSafe #define Tcl_SetResult(interp, result, freeProc) \ do { \ const char *__result = result; \ -- cgit v0.12 From ab6140e2bd9f3faceaf306511e90175e1a43bdc4 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 10 Jan 2025 21:28:27 +0000 Subject: Tcl_GetUnicode() et all (from the UTF16 compatibility layer) should be handled by TCL_NO_DEPRECATED as well, if TCL_UTF_MAX=3 --- generic/tclDecls.h | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 43857fa..d8dffdc 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -4476,6 +4476,22 @@ extern const TclStubs *tclStubsPtr; # define Tcl_UtfToUniChar Tcl_UtfToChar16 # undef Tcl_UniCharLen # define Tcl_UniCharLen Tcl_Char16Len +# ifndef TCL_NO_DEPRECATED +# undef Tcl_GetUnicode +# undef Tcl_GetUnicodeFromObj +# undef Tcl_SetUnicodeObj +# undef Tcl_AppendUnicodeToObj +# undef Tcl_UtfAtIndex +# undef Tcl_GetCharLength +# undef Tcl_UniCharNcmp +# undef Tcl_UniCharNcasecmp +# undef Tcl_UniCharCaseMatch +# undef Tcl_GetRange +# undef Tcl_GetUniChar +# undef Tcl_NumUtfChars +# undef Tcl_UtfNcmp +# undef Tcl_UtfNcasecmp +# endif #elif !defined(BUILD_tcl) # undef Tcl_NumUtfChars # define Tcl_NumUtfChars TclNumUtfChars -- cgit v0.12 From 35dfc3edbc5240707b4a9c60217115a76c63aabb Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 11 Jan 2025 21:22:45 +0000 Subject: Fix ifndef -> ifdef in previous commit --- generic/tclDecls.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclDecls.h b/generic/tclDecls.h index d8dffdc..8f80023 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -4476,7 +4476,7 @@ extern const TclStubs *tclStubsPtr; # define Tcl_UtfToUniChar Tcl_UtfToChar16 # undef Tcl_UniCharLen # define Tcl_UniCharLen Tcl_Char16Len -# ifndef TCL_NO_DEPRECATED +# ifdef TCL_NO_DEPRECATED # undef Tcl_GetUnicode # undef Tcl_GetUnicodeFromObj # undef Tcl_SetUnicodeObj -- cgit v0.12 From 2fd4839585c0ecc7a9119136e6e1e25728f40c45 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 12 Jan 2025 13:57:26 +0000 Subject: Handle TCL_NO_DEPRECATED in test code: Don't try to use deprecated API --- generic/tclTest.c | 26 +++++++++++++------------- generic/tclTestObj.c | 6 ++++++ 2 files changed, 19 insertions(+), 13 deletions(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index 5e5c14c..8db9a7a 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -144,9 +144,9 @@ typedef struct { * was called for a result. */ -#ifndef TCL_NO_DEPRECATED +#if TCL_UTF_MAX < 4 static int freeCount; -#endif /* TCL_NO_DEPRECATED */ +#endif /* TCL_UTF_MAX */ /* * Boolean flag used by the "testsetmainloop" and "testexitmainloop" commands. @@ -243,9 +243,9 @@ static Tcl_ObjCmdProc TestbytestringObjCmd; static Tcl_ObjCmdProc TestsetbytearraylengthObjCmd; static Tcl_ObjCmdProc TestpurebytesobjObjCmd; static Tcl_ObjCmdProc TeststringbytesObjCmd; -#ifndef TCL_NO_DEPRECATED +#if TCL_UTF_MAX < 4 static Tcl_ObjCmdProc Testutf16stringObjCmd; -#endif /* TCL_NO_DEPRECATED */ +#endif /* TCL_UTF_MAX */ static Tcl_ObjCmdProc TestcmdinfoObjCmd; static Tcl_CmdProc TestcmdtokenCmd; static Tcl_CmdProc TestcmdtraceCmd; @@ -297,10 +297,10 @@ static Tcl_ObjCmdProc TestregexpObjCmd; static Tcl_ObjCmdProc TestreturnObjCmd; static void TestregexpXflags(const char *string, size_t length, int *cflagsPtr, int *eflagsPtr); -#ifndef TCL_NO_DEPRECATED +#if TCL_UTF_MAX < 4 static Tcl_ObjCmdProc TestsaveresultCmd; static Tcl_FreeProc TestsaveresultFree; -#endif /* TCL_NO_DEPRECATED */ +#endif /* TCL_UTF_MAX */ static Tcl_CmdProc TestsetassocdataCmd; static Tcl_CmdProc TestsetCmd; static Tcl_CmdProc Testset2Cmd; @@ -590,9 +590,9 @@ Tcltest_Init( Tcl_CreateObjCommand(interp, "testsetbytearraylength", TestsetbytearraylengthObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testbytestring", TestbytestringObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "teststringbytes", TeststringbytesObjCmd, NULL, NULL); -#ifndef TCL_NO_DEPRECATED +#if TCL_UTF_MAX < 4 Tcl_CreateObjCommand(interp, "testutf16string", Testutf16stringObjCmd, NULL, NULL); -#endif /* TCL_NO_DEPRECATED */ +#endif /* TCL_UTF_MAX */ Tcl_CreateObjCommand2(interp, "testwrongnumargs", TestWrongNumArgsObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testfilesystem", TestFilesystemObjCmd, @@ -690,7 +690,7 @@ Tcltest_Init( NULL, NULL); Tcl_CreateObjCommand(interp, "testreturn", TestreturnObjCmd, NULL, NULL); -#ifndef TCL_NO_DEPRECATED +#if TCL_UTF_MAX < 4 Tcl_CreateObjCommand(interp, "testsaveresult", TestsaveresultCmd, NULL, NULL); #endif @@ -5798,7 +5798,7 @@ TestbytestringObjCmd( *---------------------------------------------------------------------- */ -#ifndef TCL_NO_DEPRECATED +#if TCL_UTF_MAX < 4 static int Testutf16stringObjCmd( TCL_UNUSED(void *), @@ -5817,7 +5817,7 @@ Testutf16stringObjCmd( Tcl_SetObjResult(interp, Tcl_NewUnicodeObj(p, TCL_INDEX_NONE)); return TCL_OK; } -#endif /* TCL_NO_DEPRECATED */ +#endif /* TCL_UTF_MAX */ /* *---------------------------------------------------------------------- @@ -5918,7 +5918,7 @@ Testset2Cmd( *---------------------------------------------------------------------- */ -#ifndef TCL_NO_DEPRECATED +#if TCL_UTF_MAX < 4 static int TestsaveresultCmd( TCL_UNUSED(void *), @@ -6036,7 +6036,7 @@ TestsaveresultFree( { freeCount++; } -#endif /* TCL_NO_DEPRECATED */ +#endif /* TCL_UTF_MAX */ /* *---------------------------------------------------------------------- diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index 7139674..123e1e0 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -1473,6 +1473,7 @@ TeststringobjCmd( } Tcl_SetWideIntObj(Tcl_GetObjResult(interp), length); break; +#ifndef TCL_NO_DEPRECATED case 10: { /* range */ Tcl_Size first, last; if (objc != 5) { @@ -1485,6 +1486,7 @@ TeststringobjCmd( Tcl_SetObjResult(interp, Tcl_GetRange(varPtr[varIndex], first, last)); break; } +#endif /* TCL_NO_DEPRECATED */ case 11: /* appendself */ if (objc != 4) { goto wrongNumArgs; @@ -1516,6 +1518,7 @@ TeststringobjCmd( Tcl_AppendToObj(varPtr[varIndex], string + length, size - length); Tcl_SetObjResult(interp, varPtr[varIndex]); break; +#ifndef TCL_NO_DEPRECATED case 12: /* appendself2 */ if (objc != 4) { goto wrongNumArgs; @@ -1547,6 +1550,7 @@ TeststringobjCmd( Tcl_AppendUnicodeToObj(varPtr[varIndex], unicode + length, size - length); Tcl_SetObjResult(interp, varPtr[varIndex]); break; +#endif /* TCL_NO_DEPRECATED */ case 13: /* newunicode*/ unicode = (unsigned short *)ckalloc(((unsigned)objc - 3) * sizeof(unsigned short)); for (i = 0; i < (objc - 3); ++i) { @@ -1564,6 +1568,8 @@ TeststringobjCmd( Tcl_SetObjResult(interp, varPtr[varIndex]); ckfree(unicode); break; + default: + return TCL_ERROR; } return TCL_OK; -- cgit v0.12 From 89e3ee4ed2f67754565d7b7411b549f965be3093 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 12 Jan 2025 17:35:02 +0000 Subject: In dltest/pkg*.c, prevent calling deprecate API as well --- unix/dltest/pkga.c | 3 +++ unix/dltest/pkgb.c | 3 +++ unix/dltest/pkgt.c | 3 +++ unix/dltest/pkgua.c | 4 ++++ 4 files changed, 13 insertions(+) diff --git a/unix/dltest/pkga.c b/unix/dltest/pkga.c index f249b1d..f859983 100644 --- a/unix/dltest/pkga.c +++ b/unix/dltest/pkga.c @@ -11,6 +11,9 @@ */ #undef STATIC_BUILD +#ifdef TCL_NO_DEPRECATED +# define TCL_UTF_MAX 4 /* Make sure not to use the UTf-16 compatibility wrappers */ +#endif #include "tcl.h" /* diff --git a/unix/dltest/pkgb.c b/unix/dltest/pkgb.c index 3a1d3d4..2b23a38 100644 --- a/unix/dltest/pkgb.c +++ b/unix/dltest/pkgb.c @@ -12,6 +12,9 @@ */ #undef STATIC_BUILD +#ifdef TCL_NO_DEPRECATED +# define TCL_UTF_MAX 4 /* Make sure not to use the UTf-16 compatibility wrappers */ +#endif #include "tcl.h" #if defined(_WIN32) && defined(_MSC_VER) # define snprintf _snprintf diff --git a/unix/dltest/pkgt.c b/unix/dltest/pkgt.c index 158bd9e..67ab0b1 100644 --- a/unix/dltest/pkgt.c +++ b/unix/dltest/pkgt.c @@ -11,6 +11,9 @@ */ #undef STATIC_BUILD +#ifdef TCL_NO_DEPRECATED +# define TCL_UTF_MAX 4 /* Make sure not to use the UTf-16 compatibility wrappers */ +#endif #include "tcl.h" static int TraceProc2 ( diff --git a/unix/dltest/pkgua.c b/unix/dltest/pkgua.c index c8a296e..18516b5 100644 --- a/unix/dltest/pkgua.c +++ b/unix/dltest/pkgua.c @@ -11,6 +11,10 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ +#undef STATIC_BUILD +#ifdef TCL_NO_DEPRECATED +# define TCL_UTF_MAX 4 /* Make sure not to use the UTf-16 compatibility wrappers */ +#endif #include "tcl.h" /* -- cgit v0.12 From bef67008420c0d053694ff9c6e02e4b23950f102 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 13 Jan 2025 09:37:34 +0000 Subject: Re-enable Tcl_SavedResult testcases. They won't work if TCL_NO_DEPRECATED is set. --- generic/tclTest.c | 17 ++++++++--------- 1 file changed, 8 insertions(+), 9 deletions(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index 8db9a7a..1e50106 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -24,7 +24,6 @@ #ifdef TCL_NO_DEPRECATED # define TCL_UTF_MAX 4 #else -# define TCL_NO_DEPRECATED # define TCL_UTF_MAX 3 #endif #define TCLBOOLWARNING(boolPtr) /* needed here because we compile with -Wc++-compat */ @@ -144,9 +143,9 @@ typedef struct { * was called for a result. */ -#if TCL_UTF_MAX < 4 +#ifdef TCL_NO_DEPRECATED static int freeCount; -#endif /* TCL_UTF_MAX */ +#endif /* TCL_NO_DEPRECATED */ /* * Boolean flag used by the "testsetmainloop" and "testexitmainloop" commands. @@ -297,10 +296,10 @@ static Tcl_ObjCmdProc TestregexpObjCmd; static Tcl_ObjCmdProc TestreturnObjCmd; static void TestregexpXflags(const char *string, size_t length, int *cflagsPtr, int *eflagsPtr); -#if TCL_UTF_MAX < 4 +#ifdef TCL_NO_DEPRECATED static Tcl_ObjCmdProc TestsaveresultCmd; static Tcl_FreeProc TestsaveresultFree; -#endif /* TCL_UTF_MAX */ +#endif /* TCL_NO_DEPRECATED */ static Tcl_CmdProc TestsetassocdataCmd; static Tcl_CmdProc TestsetCmd; static Tcl_CmdProc Testset2Cmd; @@ -690,10 +689,10 @@ Tcltest_Init( NULL, NULL); Tcl_CreateObjCommand(interp, "testreturn", TestreturnObjCmd, NULL, NULL); -#if TCL_UTF_MAX < 4 +#ifdef TCL_NO_DEPRECATED Tcl_CreateObjCommand(interp, "testsaveresult", TestsaveresultCmd, NULL, NULL); -#endif +#endif /* TCL_NO_DEPRECATED */ Tcl_CreateCommand(interp, "testservicemode", TestServiceModeCmd, NULL, NULL); Tcl_CreateCommand(interp, "testsetassocdata", TestsetassocdataCmd, @@ -5918,7 +5917,7 @@ Testset2Cmd( *---------------------------------------------------------------------- */ -#if TCL_UTF_MAX < 4 +#ifdef TCL_NO_DEPRECATED static int TestsaveresultCmd( TCL_UNUSED(void *), @@ -6036,7 +6035,7 @@ TestsaveresultFree( { freeCount++; } -#endif /* TCL_UTF_MAX */ +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- -- cgit v0.12 From e7a7b152eedd5ad7da7ca920e62bfd7a2197cbaf Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 13 Jan 2025 10:23:33 +0000 Subject: #ifdef TCL_NO_DEPRECATED -> #ifndef TCL_NO_DEPRECATED --- generic/tclTest.c | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index 1e50106..34d284a 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -143,7 +143,7 @@ typedef struct { * was called for a result. */ -#ifdef TCL_NO_DEPRECATED +#ifndef TCL_NO_DEPRECATED static int freeCount; #endif /* TCL_NO_DEPRECATED */ @@ -296,7 +296,7 @@ static Tcl_ObjCmdProc TestregexpObjCmd; static Tcl_ObjCmdProc TestreturnObjCmd; static void TestregexpXflags(const char *string, size_t length, int *cflagsPtr, int *eflagsPtr); -#ifdef TCL_NO_DEPRECATED +#ifndef TCL_NO_DEPRECATED static Tcl_ObjCmdProc TestsaveresultCmd; static Tcl_FreeProc TestsaveresultFree; #endif /* TCL_NO_DEPRECATED */ @@ -689,7 +689,7 @@ Tcltest_Init( NULL, NULL); Tcl_CreateObjCommand(interp, "testreturn", TestreturnObjCmd, NULL, NULL); -#ifdef TCL_NO_DEPRECATED +#ifndef TCL_NO_DEPRECATED Tcl_CreateObjCommand(interp, "testsaveresult", TestsaveresultCmd, NULL, NULL); #endif /* TCL_NO_DEPRECATED */ @@ -5917,7 +5917,7 @@ Testset2Cmd( *---------------------------------------------------------------------- */ -#ifdef TCL_NO_DEPRECATED +#ifndef TCL_NO_DEPRECATED static int TestsaveresultCmd( TCL_UNUSED(void *), -- cgit v0.12 From 74c0e694b2ccd97cb89fdc870e9c982a804bda21 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 14 Jan 2025 12:11:39 +0000 Subject: Undo previous commit, it didn't really help. Fix tests for Tcl_UtfNext/Tcl_UtfPrev, which were always expected in UTF-32 mode. Make Tcl_SetResult() usable with TCL_NO_DEPRECATED too, otherwise it leads to a test crash Always install header-files before documentation: If documentation copying takes too long it can be aborted. --- generic/tclDecls.h | 4 ++-- generic/tclTest.c | 28 +++++++++++++++++----------- unix/Makefile.in | 2 +- 3 files changed, 20 insertions(+), 14 deletions(-) diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 8f80023..dc573ec 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -4331,8 +4331,9 @@ extern const TclStubs *tclStubsPtr; #undef Tcl_SaveResult #undef Tcl_RestoreResult #undef Tcl_DiscardResult -#undef Tcl_SetResult #undef Tcl_MakeSafe +#endif /* TCL_NO_DEPRECATED */ +#undef Tcl_SetResult #define Tcl_SetResult(interp, result, freeProc) \ do { \ const char *__result = result; \ @@ -4346,7 +4347,6 @@ extern const TclStubs *tclStubsPtr; } \ } \ } while(0) -#endif /* TCL_NO_DEPRECATED */ #if defined(USE_TCL_STUBS) # if defined(_WIN32) && defined(_WIN64) diff --git a/generic/tclTest.c b/generic/tclTest.c index 34d284a..3cf0255 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -15,13 +15,14 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -#undef STATIC_BUILD #undef BUILD_tcl +#undef STATIC_BUILD #ifndef USE_TCL_STUBS # define USE_TCL_STUBS #endif #undef TCL_UTF_MAX #ifdef TCL_NO_DEPRECATED +# undef TCL_NO_DEPRECATED # define TCL_UTF_MAX 4 #else # define TCL_UTF_MAX 3 @@ -31,6 +32,11 @@ #include "tclOO.h" #include +/* We want to test the UTF-32 versions of the following 3 functions */ +#undef Tcl_UtfNext +#undef Tcl_UtfPrev +#define Tcl_UtfNext (tclStubsPtr->tcl_UtfNext) +#define Tcl_UtfPrev (tclStubsPtr->tcl_UtfPrev) /* * Required for Testregexp*Cmd */ @@ -143,9 +149,9 @@ typedef struct { * was called for a result. */ -#ifndef TCL_NO_DEPRECATED +#if TCL_UTF_MAX < 4 static int freeCount; -#endif /* TCL_NO_DEPRECATED */ +#endif /* TCL_UTF_MAX */ /* * Boolean flag used by the "testsetmainloop" and "testexitmainloop" commands. @@ -296,10 +302,10 @@ static Tcl_ObjCmdProc TestregexpObjCmd; static Tcl_ObjCmdProc TestreturnObjCmd; static void TestregexpXflags(const char *string, size_t length, int *cflagsPtr, int *eflagsPtr); -#ifndef TCL_NO_DEPRECATED +#if TCL_UTF_MAX < 4 static Tcl_ObjCmdProc TestsaveresultCmd; static Tcl_FreeProc TestsaveresultFree; -#endif /* TCL_NO_DEPRECATED */ +#endif /* TCL_UTF_MAX */ static Tcl_CmdProc TestsetassocdataCmd; static Tcl_CmdProc TestsetCmd; static Tcl_CmdProc Testset2Cmd; @@ -689,10 +695,10 @@ Tcltest_Init( NULL, NULL); Tcl_CreateObjCommand(interp, "testreturn", TestreturnObjCmd, NULL, NULL); -#ifndef TCL_NO_DEPRECATED +#if TCL_UTF_MAX < 4 Tcl_CreateObjCommand(interp, "testsaveresult", TestsaveresultCmd, NULL, NULL); -#endif /* TCL_NO_DEPRECATED */ +#endif Tcl_CreateCommand(interp, "testservicemode", TestServiceModeCmd, NULL, NULL); Tcl_CreateCommand(interp, "testsetassocdata", TestsetassocdataCmd, @@ -2167,7 +2173,7 @@ static int UtfExtWrapper( if (dstCharsVar == NULL || (valueObj = Tcl_ObjGetVar2(interp, dstCharsVar, NULL, 0)) == NULL ) { - Tcl_SetResult(interp, + Tcl_SetResult(interp, (char *) "dstCharsVar must be specified with integer value if " "TCL_ENCODING_CHAR_LIMIT set in flags.", TCL_STATIC); return TCL_ERROR; @@ -2190,7 +2196,7 @@ static int UtfExtWrapper( &dstWrote, dstCharsVar ? &dstChars : NULL); if (memcmp(bufPtr + bufLen - 4, "\xAB\xCD\xEF\xAB", 4)) { - Tcl_SetResult(interp, + Tcl_SetResult(interp, (char *) "Tcl_ExternalToUtf wrote past output buffer", TCL_STATIC); result = TCL_ERROR; @@ -5917,7 +5923,7 @@ Testset2Cmd( *---------------------------------------------------------------------- */ -#ifndef TCL_NO_DEPRECATED +#if TCL_UTF_MAX < 4 static int TestsaveresultCmd( TCL_UNUSED(void *), @@ -6035,7 +6041,7 @@ TestsaveresultFree( { freeCount++; } -#endif /* TCL_NO_DEPRECATED */ +#endif /* TCL_UTF_MAX */ /* *---------------------------------------------------------------------- diff --git a/unix/Makefile.in b/unix/Makefile.in index 1074a02..6185b71 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -994,7 +994,7 @@ INSTALL_DOC_TARGETS = install-doc INSTALL_PACKAGE_TARGETS = install-packages INSTALL_DEV_TARGETS = install-headers INSTALL_EXTRA_TARGETS = @EXTRA_INSTALL@ -INSTALL_TARGETS = $(INSTALL_BASE_TARGETS) $(INSTALL_DOC_TARGETS) $(INSTALL_DEV_TARGETS) \ +INSTALL_TARGETS = $(INSTALL_BASE_TARGETS) $(INSTALL_DEV_TARGETS) $(INSTALL_DOC_TARGETS) \ $(INSTALL_PACKAGE_TARGETS) $(INSTALL_EXTRA_TARGETS) install: $(INSTALL_TARGETS) -- cgit v0.12 From 2fe25338c3cb272a550045731f0b99ce21a36106 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 14 Jan 2025 14:16:54 +0000 Subject: Make Tcl_SetResult usable in tclTest.c, even if TCL_NO_DEPRECATED is defined --- generic/tclDecls.h | 2 +- generic/tclTest.c | 22 ++++++++++++++++++++++ 2 files changed, 23 insertions(+), 1 deletion(-) diff --git a/generic/tclDecls.h b/generic/tclDecls.h index dc573ec..a02a70f 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -4332,7 +4332,6 @@ extern const TclStubs *tclStubsPtr; #undef Tcl_RestoreResult #undef Tcl_DiscardResult #undef Tcl_MakeSafe -#endif /* TCL_NO_DEPRECATED */ #undef Tcl_SetResult #define Tcl_SetResult(interp, result, freeProc) \ do { \ @@ -4347,6 +4346,7 @@ extern const TclStubs *tclStubsPtr; } \ } \ } while(0) +#endif /* TCL_NO_DEPRECATED */ #if defined(USE_TCL_STUBS) # if defined(_WIN32) && defined(_WIN64) diff --git a/generic/tclTest.c b/generic/tclTest.c index 3cf0255..99ae05f 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -32,6 +32,25 @@ #include "tclOO.h" #include +#if TCL_UTF_MAX > 3 +/* TCL_NO_DEPRECATED was specified, so the core doesn't have a Tcl_SetResult stub entry */ +#undef Tcl_SetResult +#define Tcl_SetResult(interp, result, freeProc) \ + do { \ + const char *__result = result; \ + Tcl_FreeProc *__freeProc = freeProc; \ + Tcl_SetObjResult(interp, Tcl_NewStringObj(__result, TCL_INDEX_NONE)); \ + if (__result != NULL && __freeProc != NULL && __freeProc != TCL_VOLATILE) { \ + if (__freeProc == TCL_DYNAMIC) { \ + ckfree(__result); \ + } else { \ + (*__freeProc)((char *)__result); \ + } \ + } \ + } while(0) +#endif /* TCL_UTF_MAX */ + + /* We want to test the UTF-32 versions of the following 3 functions */ #undef Tcl_UtfNext #undef Tcl_UtfPrev @@ -524,6 +543,9 @@ static const char version[] = TCL_PATCH_LEVEL "+" STRINGIFY(TCL_VERSION_UUID) #ifdef USE_NMAKE ".nmake" #endif +#if TCL_UTF_MAX > 3 + ".no-deprecate" +#endif #if !TCL_THREADS ".no-thread" #endif -- cgit v0.12 From 3c708986bc5e40a44b5c368fb5587449dc4e935e Mon Sep 17 00:00:00 2001 From: oehhar Date: Wed, 15 Jan 2025 12:39:16 +0000 Subject: Bug 73bb42fb3f: check also 2nd encoding conversion and set error as in the one above. This is effective for the bug. --- generic/tclIO.c | 19 +++++++++++++++---- 1 file changed, 15 insertions(+), 4 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index b22019c..2d438c6 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -6446,10 +6446,21 @@ ReadChars( || BytesLeft(bufPtr->nextPtr) == 0 || 0 == (statePtr->inputEncodingFlags & TCL_ENCODING_END)); - Tcl_ExternalToUtf(NULL, encoding, src, srcLen, - (statePtr->inputEncodingFlags | TCL_ENCODING_NO_TERMINATE), - &statePtr->inputEncodingState, buffer, sizeof(buffer), - &read, &decoded, &count); + /* + * bug 73bb42fb: the result was not checked for an encoding error. + * So, add a check as above for testing. + * Leave eof check out, as typically only two characters are + * handled. + */ + + code = Tcl_ExternalToUtf(NULL, encoding, src, srcLen, + (statePtr->inputEncodingFlags | TCL_ENCODING_NO_TERMINATE), + &statePtr->inputEncodingState, buffer, sizeof(buffer), + &read, &decoded, &count); + if (code == TCL_CONVERT_UNKNOWN || code == TCL_CONVERT_SYNTAX) { + SetFlag(statePtr, CHANNEL_ENCODING_ERROR); + code = TCL_OK; + } if (count == 2) { if (buffer[1] == '\n') { -- cgit v0.12 From 5d3bc2250f603a9967f5e7847d8f6e3948c6a684 Mon Sep 17 00:00:00 2001 From: oehhar Date: Wed, 15 Jan 2025 16:59:20 +0000 Subject: Add test cases --- tests/io.test | 26 ++++++++++++++++++++++++++ 1 file changed, 26 insertions(+) diff --git a/tests/io.test b/tests/io.test index 010cd9e..0c5ebd0 100644 --- a/tests/io.test +++ b/tests/io.test @@ -1855,6 +1855,32 @@ test io-13.12 {TranslateInputEOL: find EOF char in src} { close $f set x } "\n\n\nab\n\nd" +test io-13.13 {Translation crlf: \r followed by encoding error before buffer boundary - TCL bug 73bb42fb}\ +-setup { + set buffersize 8 + writeFile $path(test1) binary\ + [string repeat x [expr $buffersize-1]]\r\xe9XXXXXXXXXXXXXXXXXXXXXXXX +} -body { + set fd [open $path(test1)] + fconfigure $fd -encoding utf-8 -buffersize [expr {$buffersize+1}] -translation crlf + catch {read $fd $buffersize} e d + list [dict get $d -data] [dict get $d -code] [dict get $d -errorcode] +} -cleanup { + close $fd +} -result {xxxxxxx 1 {POSIX EILSEQ {invalid or incomplete multibyte or wide character}}} +test io-13.14 {Translation crlf: \r followed by encoding error after buffer boundary - TCL bug 73bb42fb (crash)}\ +-setup { + set buffersize 8 + writeFile $path(test1) binary\ + [string repeat x [expr $buffersize-1]]\r\xe9XXXXXXXXXXXXXXXXXXXXXXXX +} -body { + set fd [open $path(test1)] + fconfigure $fd -encoding utf-8 -buffersize $buffersize -translation crlf + catch {read $fd $buffersize} e d + list [dict get $d -data] [dict get $d -code] [dict get $d -errorcode] +} -cleanup { + close $fd +} -result {xxxxxxx 1 {POSIX EILSEQ {invalid or incomplete multibyte or wide character}}} # Test standard handle management. The functions tested are # Tcl_SetStdChannel and Tcl_GetStdChannel. Incidentally we are -- cgit v0.12 From bb886227e18707f4fca2c63f1de773aed78573ac Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 20 Jan 2025 20:12:54 +0000 Subject: rsync-deployments -> 7.0.2 --- .github/workflows/onefiledist.yml | 2 +- library/encoding/koi8-t.enc | 0 2 files changed, 1 insertion(+), 1 deletion(-) mode change 100755 => 100644 library/encoding/koi8-t.enc diff --git a/.github/workflows/onefiledist.yml b/.github/workflows/onefiledist.yml index 4c8c6ac..3401c1b 100644 --- a/.github/workflows/onefiledist.yml +++ b/.github/workflows/onefiledist.yml @@ -205,7 +205,7 @@ jobs: working-directory: data - name: Transfer built files # https://github.com/marketplace/actions/rsync-deployments-action - uses: burnett01/rsync-deployments@7.0.1 + uses: burnett01/rsync-deployments@7.0.2 id: rsync if: false # Disabled... for now with: diff --git a/library/encoding/koi8-t.enc b/library/encoding/koi8-t.enc old mode 100755 new mode 100644 -- cgit v0.12 From 9683ab93af132e8594c7c0df9b27bd49ba1d8d24 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 22 Jan 2025 12:52:47 +0000 Subject: New function Tcl_IsEmpty() --- generic/tcl.decls | 6 ++++++ generic/tclDecls.h | 9 +++++++-- generic/tclListObj.c | 4 ++-- generic/tclStringObj.c | 45 ++++++++++++++++++++++++++++++++++++++++++++- generic/tclStubInit.c | 3 ++- 5 files changed, 61 insertions(+), 6 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 2ab1f7f..e074660 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2378,6 +2378,12 @@ declare 689 { # ----- BASELINE -- FOR -- 8.7.0 / 9.0.0 ----- # declare 690 { + int Tcl_IsEmpty(Tcl_Obj *obj) +} + +# ----- BASELINE -- FOR -- 9.1.0 ----- # + +declare 691 { void TclUnusedStubEntry(void) } diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 67d4108..fe93c10 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1874,6 +1874,8 @@ 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 void TclUnusedStubEntry(void); typedef struct { @@ -2576,7 +2578,8 @@ 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 */ + void (*tclUnusedStubEntry) (void); /* 691 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -3909,8 +3912,10 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_NewWideUIntObj) /* 688 */ #define Tcl_SetWideUIntObj \ (tclStubsPtr->tcl_SetWideUIntObj) /* 689 */ +#define Tcl_IsEmpty \ + (tclStubsPtr->tcl_IsEmpty) /* 690 */ #define TclUnusedStubEntry \ - (tclStubsPtr->tclUnusedStubEntry) /* 690 */ + (tclStubsPtr->tclUnusedStubEntry) /* 691 */ #endif /* defined(USE_TCL_STUBS) */ diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 36914bc..b8586d3 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -1970,7 +1970,7 @@ Tcl_ListObjIndex( Tcl_Size numElems; /* Empty string => empty list. Avoid unnecessary shimmering */ - if (listObj->bytes == &tclEmptyString) { + if (Tcl_IsEmpty(listObj)) { *objPtrPtr = NULL; return TCL_OK; } @@ -2024,7 +2024,7 @@ Tcl_ListObjLength( ListRep listRep; /* Empty string => empty list. Avoid unnecessary shimmering */ - if (listObj->bytes == &tclEmptyString) { + if (Tcl_IsEmpty(listObj)) { *lenPtr = 0; return TCL_OK; } diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 059f8dd..3204a24 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -1390,7 +1390,7 @@ Tcl_AppendObjToObj( } if (TclIsPureByteArray(appendObjPtr) - && (TclIsPureByteArray(objPtr) || objPtr->bytes == &tclEmptyString)) { + && (TclIsPureByteArray(objPtr) || Tcl_IsEmpty(objPtr))) { /* * Both bytearray objects are pure, so the second internal bytearray value * can be appended to the first, with no need to modify the "bytes" field. @@ -4360,6 +4360,49 @@ ExtendUnicodeRepWithString( } *dst = 0; } + +/* + *---------------------------------------------------------------------- + * + * Tcl_IsEmpty -- + * + * Check whether the obj is empty. + * + * Results: + * -1 if the obj is NULL + * 1 if the obj is "" + * 0 otherwise + * + * Side effects: + * String representation is generated if the obj has no lengthProc + * + *---------------------------------------------------------------------- + */ + +int +Tcl_IsEmpty( + Tcl_Obj *objPtr) +{ + if (objPtr == NULL) { + return -1; + } + if (objPtr->bytes && !objPtr->length) { + return 1; + } + 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/tclStubInit.c b/generic/tclStubInit.c index 9bfce36..5e0fd46 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -1509,7 +1509,8 @@ const TclStubs tclStubs = { Tcl_UtfNcasecmp, /* 687 */ Tcl_NewWideUIntObj, /* 688 */ Tcl_SetWideUIntObj, /* 689 */ - TclUnusedStubEntry, /* 690 */ + Tcl_IsEmpty, /* 690 */ + TclUnusedStubEntry, /* 691 */ }; /* !END!: Do not edit above this line. */ -- cgit v0.12 From 3c0d56311c277c5aa7bb7628c367e8c1e1befc32 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 24 Jan 2025 10:06:07 +0000 Subject: Turn some defines into enums, plus other minor cleanup in the win console code --- win/tclWinConsole.c | 155 ++++++++++++++++++++++++++-------------------------- 1 file changed, 78 insertions(+), 77 deletions(-) diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index 7b73780..9e9f6c0 100644 --- a/win/tclWinConsole.c +++ b/win/tclWinConsole.c @@ -36,9 +36,9 @@ * multiple Tcl channels corresponding to a single console handle. * * - Even with multiple threads, more than one file event handler is - * unlikely. It does not make sense for multiple threads to register - * handlers for stdin because the input would be randomly fragmented amongst - * the threads. + * unlikely. It does not make sense for multiple threads to register + * handlers for stdin because the input would be randomly fragmented amongst + * the threads. * * Various design factors are driven by the above, e.g. use of lists instead * of hash tables (at most 3 console handles) and use of global instead of @@ -58,7 +58,7 @@ * * If multiple threads are reading from stdin, the input is sprayed in * random fashion. This is not good application design and hence no plan to - * address this (not clear what should be done even in theory) + * address this (not clear what should be done even in theory). * * For output, we do not restrict all output to the console writer threads. * See ConsoleOutputProc for the conditions. @@ -94,14 +94,18 @@ static int gInitialized = 0; * and bufPtr[0]:bufPtr[length - (size-start)]. */ typedef struct RingBuffer { - char *bufPtr; /* Pointer to buffer storage */ - Tcl_Size capacity; /* Size of the buffer in RingBufferChar */ - Tcl_Size start; /* Start of the data within the buffer. */ - Tcl_Size length; /* Number of RingBufferChar*/ + char *bufPtr; /* Pointer to buffer storage */ + Tcl_Size capacity; /* Size of the buffer in RingBufferChar */ + Tcl_Size start; /* Start of the data within the buffer. */ + Tcl_Size length; /* Number of RingBufferChar*/ } RingBuffer; -#define RingBufferLength(ringPtr_) ((ringPtr_)->length) -#define RingBufferHasFreeSpace(ringPtr_) ((ringPtr_)->length < (ringPtr_)->capacity) -#define RINGBUFFER_ASSERT(ringPtr_) assert(RingBufferCheck(ringPtr_)) + +#define RingBufferLength(ringPtr_) \ + ((ringPtr_)->length) +#define RingBufferHasFreeSpace(ringPtr_) \ + ((ringPtr_)->length < (ringPtr_)->capacity) +#define RINGBUFFER_ASSERT(ringPtr_) \ + assert(RingBufferCheck(ringPtr_)) /* * The Win32 console API does not support non-blocking I/O in any form. Thus @@ -126,28 +130,34 @@ typedef struct RingBuffer { */ typedef struct ConsoleHandleInfo { struct ConsoleHandleInfo *nextPtr; /* Process-global list of consoles */ - HANDLE console; /* Console handle */ - HANDLE consoleThread; /* Handle to thread doing actual i/o on the console */ - SRWLOCK lock; /* Controls access to this structure. - * Cheaper than CRITICAL_SECTION but note does not - * support recursive locks or Try* style attempts.*/ + HANDLE console; /* Console handle */ + HANDLE consoleThread; /* Handle to thread doing actual i/o on the + * console */ + SRWLOCK lock; /* Controls access to this structure. Cheaper + * than CRITICAL_SECTION but note does not + * support recursive locks or Try* style + * attempts. */ CONDITION_VARIABLE consoleThreadCV;/* For awakening console thread */ CONDITION_VARIABLE interpThreadCV; /* For awakening interpthread(s) */ - RingBuffer buffer; /* Buffer for data transferred between console - * threads and Tcl threads. For input consoles, - * written by the console thread and read by Tcl - * threads. The converse for output threads */ - DWORD initMode; /* Initial console mode. */ - DWORD lastError; /* An error caused by the last background - * operation. Set to 0 if no error has been - * detected. */ - int numRefs; /* See comments above */ - int permissions; /* TCL_READABLE for input consoles, TCL_WRITABLE - * for output. Only one or the other can be set. */ - int flags; -#define CONSOLE_DATA_AWAITED 0x0001 /* An interpreter is awaiting data */ + RingBuffer buffer; /* Buffer for data transferred between console + * threads and Tcl threads. For input consoles, + * written by the console thread and read by Tcl + * threads. The converse for output threads */ + DWORD initMode; /* Initial console mode. */ + DWORD lastError; /* An error caused by the last background + * operation. Set to 0 if no error has been + * detected. */ + int numRefs; /* See comments above */ + int permissions; /* TCL_READABLE for input consoles, + * TCL_WRITABLE for output. Only one or the + * other can be set. */ + int flags; /* State flags */ } ConsoleHandleInfo; +enum ConsoleHandleInfoFlags { + CONSOLE_DATA_AWAITED = 1 /* An interpreter is awaiting data */ +}; + /* * This structure describes per-instance data for a console based channel. * @@ -190,11 +200,14 @@ typedef struct ConsoleChannelInfo { * TCL_WRITABLE, or TCL_EXCEPTION: indicates * which events should be reported. */ int flags; /* State flags */ -#define CONSOLE_EVENT_QUEUED 0x0001 /* Notification event already queued */ -#define CONSOLE_ASYNC 0x0002 /* Channel is non-blocking. */ -#define CONSOLE_READ_OPS 0x0004 /* Channel supports read-related ops. */ } ConsoleChannelInfo; +enum ConsoleChannelInfoFlags { + CONSOLE_EVENT_QUEUED = 1, /* Notification event already queued */ + CONSOLE_ASYNC = 2, /* Channel is non-blocking. */ + CONSOLE_READ_OPS = 4 /* Channel supports read-related ops. */ +}; + /* * The following structure is what is added to the Tcl event queue when * console events are generated. @@ -424,7 +437,7 @@ RingBufferIn( } else { /* No room at the back. Existing data wrap to front. */ Tcl_Size wrapLen = - ringPtr->start + ringPtr->length - ringPtr->capacity; + ringPtr->start + ringPtr->length - ringPtr->capacity; memmove(wrapLen + ringPtr->bufPtr, srcPtr, srcLen); } @@ -484,11 +497,8 @@ RingBufferOut( } else { Tcl_Size wrapLen = dstCapacity - leadLen; if (dstPtr) { - memmove(dstPtr, - ringPtr->start + ringPtr->bufPtr, - leadLen); - memmove( - leadLen + dstPtr, ringPtr->bufPtr, wrapLen); + memmove(dstPtr, ringPtr->start + ringPtr->bufPtr, leadLen); + memmove(leadLen + dstPtr, ringPtr->bufPtr, wrapLen); } ringPtr->start = wrapLen; } @@ -539,7 +549,6 @@ ReadConsoleChars( Tcl_Size *nCharsReadPtr) { DWORD nRead; - BOOL result; /* * If user types a Ctrl-Break or Ctrl-C, ReadConsole will return success @@ -561,17 +570,15 @@ ReadConsoleChars( * or https://github.com/microsoft/terminal/issues/12143 */ nRead = (DWORD)-1; - result = ReadConsoleW(hConsole, lpBuffer, nChars, &nRead, NULL); - if (result) { - if ((nRead == 0 || nRead == (DWORD)-1) - && GetLastError() == ERROR_OPERATION_ABORTED) { - nRead = 0; - } - *nCharsReadPtr = nRead; - return 0; - } else { + if (!ReadConsoleW(hConsole, lpBuffer, nChars, &nRead, NULL)) { return GetLastError(); } + if ((nRead == 0 || nRead == (DWORD)-1) + && GetLastError() == ERROR_OPERATION_ABORTED) { + nRead = 0; + } + *nCharsReadPtr = nRead; + return 0; } /* @@ -600,20 +607,17 @@ WriteConsoleChars( Tcl_Size *nCharsWrittenPtr) { DWORD nCharsWritten; - BOOL result; /* See comments in ReadConsoleChars, not sure that applies here */ nCharsWritten = (DWORD)-1; - result = WriteConsoleW(hConsole, lpBuffer, nChars, &nCharsWritten, NULL); - if (result) { - if (nCharsWritten == (DWORD) -1) { - nCharsWritten = 0; - } - *nCharsWrittenPtr = nCharsWritten; - return 0; - } else { + if (!WriteConsoleW(hConsole, lpBuffer, nChars, &nCharsWritten, NULL)) { return GetLastError(); } + if (nCharsWritten == (DWORD) -1) { + nCharsWritten = 0; + } + *nCharsWrittenPtr = nCharsWritten; + return 0; } /* @@ -787,8 +791,7 @@ ConsoleSetupProc( for (chanInfoPtr = gWatchingChannelList; block && chanInfoPtr != NULL; chanInfoPtr = chanInfoPtr->nextWatchingChannelPtr) { - ConsoleHandleInfo *handleInfoPtr; - handleInfoPtr = FindConsoleInfo(chanInfoPtr); + ConsoleHandleInfo *handleInfoPtr = FindConsoleInfo(chanInfoPtr); if (handleInfoPtr != NULL) { AcquireSRWLockShared(&handleInfoPtr->lock); /* Remember at most one of READABLE, WRITABLE set */ @@ -1562,10 +1565,9 @@ ConsoleGetHandleProc( if (chanInfoPtr->handle == INVALID_HANDLE_VALUE) { return TCL_ERROR; - } else { - *handlePtr = chanInfoPtr->handle; - return TCL_OK; } + *handlePtr = chanInfoPtr->handle; + return TCL_OK; } /* @@ -1583,8 +1585,8 @@ ConsoleGetHandleProc( * *------------------------------------------------------------------------ */ - static int - ConsoleDataAvailable( +static int +ConsoleDataAvailable( HANDLE consoleHandle) { INPUT_RECORD input[10]; @@ -1617,7 +1619,7 @@ ConsoleGetHandleProc( } return 0; } - + /* *---------------------------------------------------------------------- * @@ -1634,7 +1636,6 @@ ConsoleGetHandleProc( * *---------------------------------------------------------------------- */ - static DWORD WINAPI ConsoleReaderThread( LPVOID arg) @@ -1968,7 +1969,6 @@ ConsoleWriterThread( ReleaseSRWLockExclusive(&gConsoleLock); RingBufferClear(&handleInfoPtr->buffer); - Tcl_Free(handleInfoPtr); return 0; @@ -2023,12 +2023,12 @@ AllocateConsoleHandleInfo( SetConsoleMode(consoleHandle, consoleMode); } handleInfoPtr->consoleThread = CreateThread( - NULL, /* default security descriptor */ - 2*CONSOLE_BUFFER_SIZE, /* Stack size - gets rounded up to granularity */ - permissions == TCL_READABLE ? ConsoleReaderThread : ConsoleWriterThread, - handleInfoPtr, /* Pass to thread */ - 0, /* Flags - no special cases */ - NULL); /* Don't care about thread id */ + NULL, /* default security descriptor */ + 2*CONSOLE_BUFFER_SIZE, /* Stack size - gets rounded up to granularity */ + permissions == TCL_READABLE ? ConsoleReaderThread : ConsoleWriterThread, + handleInfoPtr, /* Pass to thread */ + 0, /* Flags - no special cases */ + NULL); /* Don't care about thread id */ if (handleInfoPtr->consoleThread == NULL) { /* Note - SRWLock and condition variables do not need finalization */ RingBufferClear(&handleInfoPtr->buffer); @@ -2071,14 +2071,15 @@ FindConsoleInfo( const ConsoleChannelInfo *chanInfoPtr) { ConsoleHandleInfo *handleInfoPtr; - for (handleInfoPtr = gConsoleHandleInfoList; handleInfoPtr; handleInfoPtr = handleInfoPtr->nextPtr) { + for (handleInfoPtr = gConsoleHandleInfoList; handleInfoPtr; + handleInfoPtr = handleInfoPtr->nextPtr) { if (handleInfoPtr->console == chanInfoPtr->handle) { return handleInfoPtr; } } return NULL; } - + /* *---------------------------------------------------------------------- * @@ -2258,7 +2259,7 @@ ConsoleThreadActionProc( */ static int ConsoleSetOptionProc( - void *instanceData, /* File state. */ + void *instanceData, /* File state. */ Tcl_Interp *interp, /* For error reporting - can be NULL. */ const char *optionName, /* Which option to set? */ const char *value) /* New value for option. */ @@ -2347,7 +2348,7 @@ ConsoleSetOptionProc( static int ConsoleGetOptionProc( - void *instanceData, /* File state. */ + void *instanceData, /* File state. */ Tcl_Interp *interp, /* For error reporting - can be NULL. */ const char *optionName, /* Option to get. */ Tcl_DString *dsPtr) /* Where to store value(s). */ -- cgit v0.12 From e0d39ceda995d082622e8593bf64d621deb90d6e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 25 Jan 2025 11:18:22 +0000 Subject: Fix comment --- generic/tclIcu.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclIcu.c b/generic/tclIcu.c index 86d28a2..1dd901b 100644 --- a/generic/tclIcu.c +++ b/generic/tclIcu.c @@ -1434,7 +1434,7 @@ TclIcuInit( } #endif // _WIN32 - /* Symbol may have version (Windows, FreeBSD), or not (Linux) */ + /* Symbol may have version (Linux), or not (Windows, FreeBSD) */ #define ICUUC_SYM(name) \ do { \ -- cgit v0.12 From b1129d299b48bb51e6d089b4b82e291013276dcd Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sun, 26 Jan 2025 04:24:51 +0000 Subject: Proposed fix [4f0b5767ac]. exec of App Execution Alias --- win/tclWinPipe.c | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c index 7b083a5..6949877 100644 --- a/win/tclWinPipe.c +++ b/win/tclWinPipe.c @@ -1327,11 +1327,22 @@ ApplicationType( hFile = CreateFileW(nativeFullPath, GENERIC_READ, FILE_SHARE_READ, NULL, OPEN_EXISTING, - FILE_ATTRIBUTE_NORMAL, NULL); + FILE_ATTRIBUTE_NORMAL|FILE_FLAG_OPEN_REPARSE_POINT, NULL); if (hFile == INVALID_HANDLE_VALUE) { continue; } + if (attr & FILE_ATTRIBUTE_REPARSE_POINT) { + /* + * But [4f0b5767ac]. Likely a App Execution Alias. This can only + * be a Win32 APP. Attempt to ReadFile below will fail. We assume + * that if it is on the PATH, and it is a reparse point, it is an + * App Execution Alias. + */ + applType = APPL_WIN32; + break; + } + header.e_magic = 0; ReadFile(hFile, (void *)&header, sizeof(header), &read, NULL); if (header.e_magic != IMAGE_DOS_SIGNATURE) { -- cgit v0.12 From 84347866b7b2ad4bb6413eb040de828b6fd91f03 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sun, 26 Jan 2025 04:39:19 +0000 Subject: Added test for [4f0b5767ac]. --- tests/exec.test | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/tests/exec.test b/tests/exec.test index d2f42af..353d3b6 100644 --- a/tests/exec.test +++ b/tests/exec.test @@ -23,6 +23,12 @@ source [file join [file dirname [info script]] tcltests.tcl] # Some skips when running in a macOS CI environment testConstraint noosxCI [expr {![info exists ::env(MAC_CI)]}] +# Need a App Exec Alias for testing exec of reparse points +if {[info exists ::env(LOCALAPPDATA)] && + [file exists [file join $::env(LOCALAPPDATA) "Microsoft" "WindowsApps" "winget.exe"]]} { + testConstraint haveWinget 1 +} + unset -nocomplain path # Utilities that are like Bourne shell stalwarts, but cross-platform. @@ -741,6 +747,10 @@ test exec-21.2 {exec encoding mismatch on stderr} -setup { list [catch {exec [info nameofexecutable] $path(script)} r] $r } -result [list 1 a\uFFFDb] +test exec-bug-4f0b5767ac {exec App Execution Alias} -constraints haveWinget -body { + exec winget --info +} -result "Windows Package Manager*" -match glob + # ---------------------------------------------------------------------- # cleanup -- cgit v0.12 From fbe7addb0d93881dbb7f7b7a5ea686b955478924 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sun, 26 Jan 2025 08:03:09 +0000 Subject: Bug [4e2c8bc4a7]. Missing auto_execok cmd builtins --- library/init.tcl | 6 ++++-- tests/exec.test | 13 +++++++++++++ 2 files changed, 17 insertions(+), 2 deletions(-) diff --git a/library/init.tcl b/library/init.tcl index 2d8d0dd..d691baf 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -590,8 +590,10 @@ proc auto_execok name { } set auto_execs($name) "" - set shellBuiltins [list assoc cls copy date del dir echo erase exit ftype \ - md mkdir mklink move rd ren rename rmdir start time type ver vol] + set shellBuiltins [list assoc call cd cls color copy date del dir echo \ + erase exit ftype for if md mkdir mklink move path \ + pause prompt rd ren rename rmdir set start time \ + title type ver vol] if {[info exists env(PATHEXT)]} { # Add an initial ; to have the {} extension check first. set execExtensions [split ";$env(PATHEXT)" ";"] diff --git a/tests/exec.test b/tests/exec.test index d2f42af..005d86e 100644 --- a/tests/exec.test +++ b/tests/exec.test @@ -741,6 +741,19 @@ test exec-21.2 {exec encoding mismatch on stderr} -setup { list [catch {exec [info nameofexecutable] $path(script)} r] $r } -result [list 1 a\uFFFDb] +foreach cmdBuiltin { + assoc call cd cls color copy date del dir echo + erase exit ftype for if md mkdir mklink move path + pause prompt rd ren rename rmdir set start time + title type ver vol +} { + test auto_execok-$cmdBuiltin-1.0 "auto_execok $cmdBuiltin" \ + -constraints win \ + -body "auto_execok $cmdBuiltin" \ + -result "[file normalize $::env(COMSPEC)] /c $cmdBuiltin" +} +unset cmdBuiltin + # ---------------------------------------------------------------------- # cleanup -- cgit v0.12 From 6f2ff71243c0553b78ba13145970f7751484003e Mon Sep 17 00:00:00 2001 From: oehhar Date: Mon, 27 Jan 2025 11:33:02 +0000 Subject: Ticket [27fa20249d]: guard html generation against bogus package folders. --- tools/tcltk-man2html.tcl | 3 +++ 1 file changed, 3 insertions(+) diff --git a/tools/tcltk-man2html.tcl b/tools/tcltk-man2html.tcl index 8cc34c5..2fa4bce 100755 --- a/tools/tcltk-man2html.tcl +++ b/tools/tcltk-man2html.tcl @@ -760,6 +760,9 @@ try { break } } + } on error {} { + puts "package folder without package ignored: $dir" + continue } finally { catch {close $f; unset f} } -- cgit v0.12 From 6d954b2130539d4586d6d66fbee6f5589fa0de86 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 27 Jan 2025 15:55:46 +0000 Subject: Add documentation --- doc/StringObj.3 | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/doc/StringObj.3 b/doc/StringObj.3 index f53b670..5d6a90d 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 \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 @@ -402,6 +405,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 +NULL, 1 if \fIobjPtr\fR is the empty string, 0 otherwise. +It doesn't generate the string representation (unless the +type is unknown), 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, -- cgit v0.12 From 23031d29f190a82ec68bcf61517d79f1bdbdadbc Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Mon, 27 Jan 2025 16:59:55 +0000 Subject: Fix auto_exec test for Unix even in presence of win constraint --- tests/exec.test | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/tests/exec.test b/tests/exec.test index 005d86e..c3c8132 100644 --- a/tests/exec.test +++ b/tests/exec.test @@ -749,8 +749,10 @@ foreach cmdBuiltin { } { test auto_execok-$cmdBuiltin-1.0 "auto_execok $cmdBuiltin" \ -constraints win \ - -body "auto_execok $cmdBuiltin" \ - -result "[file normalize $::env(COMSPEC)] /c $cmdBuiltin" + -body { + string equal [auto_execok $cmdBuiltin] \ + "[file normalize $::env(COMSPEC)] /c $cmdBuiltin" + } -result 1 } unset cmdBuiltin -- cgit v0.12 From 08894354334a3b91546f0ef2581c2a62fa70bed8 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 29 Jan 2025 13:00:15 +0000 Subject: Test whether all tests work fine on MacOS-15 --- .github/workflows/mac-build.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/mac-build.yml b/.github/workflows/mac-build.yml index 4e26d19..e33b12a 100644 --- a/.github/workflows/mac-build.yml +++ b/.github/workflows/mac-build.yml @@ -11,7 +11,7 @@ permissions: contents: read jobs: xcode: - runs-on: macos-14 + runs-on: macos-15 defaults: run: shell: bash @@ -36,7 +36,7 @@ jobs: MAC_CI: 1 timeout-minutes: 15 clang: - runs-on: macos-14 + runs-on: macos-15 strategy: matrix: config: -- cgit v0.12 From 6dd788dfc6d4d953c3c91154b6304b9acd80e433 Mon Sep 17 00:00:00 2001 From: max Date: Fri, 31 Jan 2025 14:47:13 +0000 Subject: Initial reference implementation of TIP 712 (Add "positive" options to the subst command) with code, documentation and tests. --- doc/subst.n | 15 +++++++++++++++ generic/tclCmdMZ.c | 33 ++++++++++++++++++++++++++++++--- tests/subst.test | 44 ++++++++++++++++++++++++++++++++++++-------- 3 files changed, 81 insertions(+), 11 deletions(-) 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/tclCmdMZ.c b/generic/tclCmdMZ.c index 4ab0732..012d1bc 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -3337,12 +3337,15 @@ TclSubstOptions( int *flagPtr) { static const char *const substOptions[] = { - "-nobackslashes", "-nocommands", "-novariables", NULL + "-nobackslashes", "-nocommands", "-novariables", + "-backslashes", "-commands", "-variables", NULL }; enum { - SUBST_NOBACKSLASHES, SUBST_NOCOMMANDS, SUBST_NOVARS + SUBST_NOBACKSLASHES, SUBST_NOCOMMANDS, SUBST_NOVARS, + SUBST_BACKSLASHES, SUBST_COMMANDS, SUBST_VARS }; int i, flags = TCL_SUBST_ALL; + int positive = 0, negative = 0; for (i = 0; i < numOpts; i++) { int optionIndex; @@ -3351,6 +3354,20 @@ TclSubstOptions( &optionIndex) != TCL_OK) { return TCL_ERROR; } + if (optionIndex >= SUBST_NOBACKSLASHES && + optionIndex <= SUBST_NOVARS) { + negative = 1; + } else if (optionIndex >= SUBST_BACKSLASHES && + optionIndex <= SUBST_VARS && positive == 0) { + positive = 1; + /* Swap the default at the first positive switch */ + flags = 0; + } + if (positive && negative) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "positive and negative switches cannot be combined", -1)); + return TCL_ERROR; + } switch (optionIndex) { case SUBST_NOBACKSLASHES: flags &= ~TCL_SUBST_BACKSLASHES; @@ -3361,6 +3378,15 @@ TclSubstOptions( case SUBST_NOVARS: flags &= ~TCL_SUBST_VARIABLES; break; + case SUBST_BACKSLASHES: + flags |= TCL_SUBST_BACKSLASHES; + break; + case SUBST_COMMANDS: + flags |= TCL_SUBST_COMMANDS; + break; + case SUBST_VARS: + flags |= TCL_SUBST_VARIABLES; + break; default: Tcl_Panic("Tcl_SubstObjCmd: bad option index to SubstOptions"); } @@ -3390,7 +3416,8 @@ TclNRSubstObjCmd( if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, - "?-nobackslashes? ?-nocommands? ?-novariables? string"); + "?-nobackslashes? ?-nocommands? ?-novariables? " + "?-backslashes? ?-commands? ?-variables? string"); return TCL_ERROR; } diff --git a/tests/subst.test b/tests/subst.test index da59c3b..3c68ecb 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 ?-nobackslashes? ?-nocommands? ?-novariables? ?-backslashes? ?-commands? ?-variables? 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 -nobackslashes, -nocommands, -novariables, -backslashes, -commands, or -variables} test subst-2.1 {simple strings} { subst {} @@ -123,29 +123,57 @@ 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 -nobackslashes, -nocommands, -novariables, -backslashes, -commands, or -variables} 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 -nobackslashes, -nocommands, -novariables, -backslashes, -commands, or -variables} test subst-7.3 {switches} -returnCodes error -body { subst -bogus bar -} -result {bad option "-bogus": must be -nobackslashes, -nocommands, or -novariables} -test subst-7.4 {switches} { +} -result {bad option "-bogus": must be -nobackslashes, -nocommands, -novariables, -backslashes, -commands, or -variables} +test subst-7.4.1 {switches} { set x 123 subst -nobackslashes {abc $x [expr {1 + 2}] \\\x41} } {abc 123 3 \\\x41} -test subst-7.5 {switches} { +test subst-7.4.2 {switches} { + set x 123 + subst -commands -variables {abc $x [expr {1 + 2}] \\\x41} +} {abc 123 3 \\\x41} +test subst-7.5.1 {switches} { set x 123 subst -nocommands {abc $x [expr {1 + 2}] \\\x41} } {abc 123 [expr {1 + 2}] \A} -test subst-7.6 {switches} { +test subst-7.5.2 {switches} { + set x 123 + subst -backslashes -variables {abc $x [expr {1 + 2}] \\\x41} +} {abc 123 [expr {1 + 2}] \A} +test subst-7.6.1 {switches} { set x 123 subst -novariables {abc $x [expr {1 + 2}] \\\x41} } {abc $x 3 \A} +test subst-7.6.2 {switches} { + set x 123 + subst -backslashes -commands {abc $x [expr {1 + 2}] \\\x41} +} {abc $x 3 \A} 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 {switches} { + set x 123 + subst -backslashes {abc $x [expr {1 + 2}] \\\x41} +} {abc $x [expr {1 + 2}] \A} +test subst-7.9 {switches} { + set x 123 + subst -commands {abc $x [expr {1 + 2}] \\\x41} +} {abc $x 3 \\\x41} +test subst-7.10 {switches} { + set x 123 + subst -variables {abc $x [expr {1 + 2}] \\\x41} +} {abc 123 [expr {1 + 2}] \\\x41} +test subst-7.11 {switches} { + set x 123 + subst -ba -co -va {abc $x [expr {1 + 2}] \\\x41} +} {abc 123 3 \A} test subst-8.1 {return in a subst} { subst {foo [return {x}; bogus code] bar} -- cgit v0.12 From 40db447fe696f5e55dd8818bde390bda543cd845 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 31 Jan 2025 17:40:17 +0000 Subject: (cherry-pick): Ticket [73bb42fb3f] Panic "Buffer Underflow, BUFFER_PADDING not enough" due to not checked encoding decode result. Fix some indenting (spacing) in testcases (all backported from 9.0) --- generic/tclIO.c | 81 ++++++++++++++++++++++++++++----------------------- tests/aaa_exit.test | 4 +-- tests/clock.test | 16 +++++----- tests/cmdAH.test | 24 +++++++-------- tests/expr.test | 26 ++++++++--------- tests/fileSystem.test | 4 +-- tests/for.test | 2 +- tests/internals.tcl | 2 +- tests/io.test | 26 +++++++++++++++++ tests/ioCmd.test | 2 +- tests/lmap.test | 10 +++---- tests/msgcat.test | 12 ++++---- tests/namespace.test | 2 +- tests/ooUtil.test | 2 +- tests/socket.test | 8 ++--- tests/switch.test | 6 ++-- tests/unixNotfy.test | 4 +-- tests/var.test | 4 +-- 18 files changed, 135 insertions(+), 100 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index d9aae23..60e558c 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -246,7 +246,7 @@ static int WillRead(Channel *chanPtr); * * Returns the number of bytes of data remaining in the buffer. * - * int SpaceLeft(ChannelBuffer *bufPtr) + * Tcl_Size SpaceLeft(ChannelBuffer *bufPtr) * * Returns the number of bytes of space remaining at the end of the * buffer. @@ -1532,8 +1532,8 @@ TclGetChannelFromObj( ChanGetInternalRep(objPtr, resPtr); if (resPtr) { /* - * Confirm validity of saved lookup results. - */ + * Confirm validity of saved lookup results. + */ statePtr = resPtr->statePtr; if ((resPtr->interp == interp) /* Same interp context */ @@ -1601,7 +1601,7 @@ Tcl_Channel Tcl_CreateChannel( const Tcl_ChannelType *typePtr, /* The channel type record. */ const char *chanName, /* Name of channel to record. */ - void *instanceData, /* Instance specific data. */ + void *instanceData, /* Instance specific data. */ int mask) /* TCL_READABLE & TCL_WRITABLE to indicate if * the channel is readable, writable. */ { @@ -1839,7 +1839,7 @@ Tcl_StackChannel( const Tcl_ChannelType *typePtr, /* The channel type record for the new * channel. */ - void *instanceData, /* Instance specific data for the new + void *instanceData, /* Instance specific data for the new * channel. */ int mask, /* TCL_READABLE & TCL_WRITABLE to indicate if * the channel is readable, writable. */ @@ -4490,16 +4490,11 @@ Write( * current output encoding and strict encoding is active. */ - if (result == TCL_CONVERT_UNKNOWN || result == TCL_CONVERT_SYNTAX) { - encodingError = 1; - result = TCL_OK; - } - - if ((result != TCL_OK) && (srcRead + dstWrote == 0)) { - /* - * We're reading from invalid/incomplete UTF-8. - */ - + if ((result == TCL_CONVERT_UNKNOWN || result == TCL_CONVERT_SYNTAX) || + /* + * We're reading from invalid/incomplete UTF-8. + */ + ((result != TCL_OK) && (srcRead + dstWrote == 0))) { encodingError = 1; result = TCL_OK; } @@ -4575,15 +4570,15 @@ Write( flushed += statePtr->bufSize; /* - * We just flushed. So if we have needNlFlush set to record that - * we need to flush because there is a (translated) newline in the - * buffer, that's likely not true any more. But there is a tricky - * exception. If we have saved bytes that did not really get - * flushed and those bytes came from a translation of a newline as - * the last thing taken from the src array, then needNlFlush needs - * to remain set to flag that the next buffer still needs a - * newline flush. - */ + * We just flushed. So if we have needNlFlush set to record that + * we need to flush because there is a (translated) newline in the + * buffer, that's likely not true any more. But there is a tricky + * exception. If we have saved bytes that did not really get + * flushed and those bytes came from a translation of a newline as + * the last thing taken from the src array, then needNlFlush needs + * to remain set to flag that the next buffer still needs a + * newline flush. + */ if (needNlFlush && (saved == 0 || src[-1] != '\n')) { needNlFlush = 0; @@ -5750,13 +5745,13 @@ CommonGetsCleanup( nextPtr = bufPtr->nextPtr; for ( ; nextPtr != NULL; nextPtr = bufPtr->nextPtr) { - int extra; + Tcl_Size extra; extra = SpaceLeft(bufPtr); if (extra > 0) { memcpy(InsertPoint(bufPtr), nextPtr->buf + (BUFFER_PADDING - extra), - (size_t) extra); + (size_t)extra); bufPtr->nextAdded += extra; nextPtr->nextRemoved = BUFFER_PADDING; } @@ -6352,7 +6347,9 @@ ReadChars( int factor = *factorPtr; int dstLimit = TCL_UTF_MAX - 1 + toRead * factor / UTF_EXPANSION_FACTOR; - if (dstLimit <= 0) dstLimit = INT_MAX; /* avoid overflow */ + if (dstLimit <= 0) { + dstLimit = INT_MAX; /* avoid overflow */ + } (void)TclGetStringFromObj(objPtr, &numBytes); TclAppendUtfToUtf(objPtr, NULL, dstLimit); if (toRead == srcLen) { @@ -6529,10 +6526,21 @@ ReadChars( || BytesLeft(bufPtr->nextPtr) == 0 || 0 == (statePtr->inputEncodingFlags & TCL_ENCODING_END)); - Tcl_ExternalToUtf(NULL, encoding, src, srcLen, - (statePtr->inputEncodingFlags | TCL_ENCODING_NO_TERMINATE), - &statePtr->inputEncodingState, buffer, sizeof(buffer), - &read, &decoded, &count); + /* + * bug 73bb42fb: the result was not checked for an encoding error. + * So, add a check as above for testing. + * Leave eof check out, as typically only two characters are + * handled. + */ + + code = Tcl_ExternalToUtf(NULL, encoding, src, srcLen, + (statePtr->inputEncodingFlags | TCL_ENCODING_NO_TERMINATE), + &statePtr->inputEncodingState, buffer, sizeof(buffer), + &read, &decoded, &count); + if (code == TCL_CONVERT_UNKNOWN || code == TCL_CONVERT_SYNTAX) { + SetFlag(statePtr, CHANNEL_ENCODING_ERROR); + code = TCL_OK; + } if (count == 2) { if (buffer[1] == '\n') { @@ -10198,12 +10206,12 @@ CopyData( * * Results: * The number of bytes actually stored (<= bytesToRead), - * or TCL_INDEX_NONE if there is an error in reading the channel. Use - * Tcl_GetErrno() to retrieve the error code for the error + * or TCL_INDEX_NONE if there is an error in reading the channel. Use + * Tcl_GetErrno() to retrieve the error code for the error * that occurred. * * The number of bytes stored can be less than the number - * requested when + * requested when * - EOF is reached on the channel; or * - the channel is non-blocking, and we've read all we can * without blocking. @@ -10284,7 +10292,7 @@ DoRead( */ while (!bufPtr || /* We got no buffer! OR */ - (!IsBufferFull(bufPtr) && /* Our buffer has room AND */ + (!IsBufferFull(bufPtr) && /* Our buffer has room AND */ ((Tcl_Size) BytesLeft(bufPtr) < bytesToRead))) { /* Not enough bytes in it yet * to fill the dst */ @@ -10923,7 +10931,8 @@ Tcl_IsChannelExisting( const char * Tcl_ChannelName( - const Tcl_ChannelType *chanTypePtr) /* Pointer to channel type. */ + const Tcl_ChannelType *chanTypePtr) + /* Pointer to channel type. */ { return chanTypePtr->typeName; } diff --git a/tests/aaa_exit.test b/tests/aaa_exit.test index fffc1cc..68bb701 100644 --- a/tests/aaa_exit.test +++ b/tests/aaa_exit.test @@ -22,7 +22,7 @@ test exit-1.1 {normal, quick exit} { fileevent $f readable {after cancel $aft;set done OK} vwait done if {$done != "OK"} { - fconfigure $f -blocking 0 + fconfigure $f -blocking 0 close $f } else { if {[catch {close $f} err]} { @@ -38,7 +38,7 @@ test exit-1.2 {full-finalized exit} { fileevent $f readable {after cancel $aft;set done OK} vwait done if {$done != "OK"} { - fconfigure $f -blocking 0 + fconfigure $f -blocking 0 close $f } else { if {[catch {close $f} err]} { diff --git a/tests/clock.test b/tests/clock.test index c97bef5..c710f0e 100644 --- a/tests/clock.test +++ b/tests/clock.test @@ -36776,15 +36776,15 @@ test clock-34.70.1 {check date in DST-hole: daylight switch CET -> CEST} { # forwards set base 1459033200 for {set i 0} {$i <= 3} {incr i} { - set d [clock scan "+$i hour" -base $base -timezone CET] - lappend res "$d = [clock format $d -timezone CET -format {%Y-%m-%d %H:%M:%S %Z}]" + set d [clock scan "+$i hour" -base $base -timezone CET] + lappend res "$d = [clock format $d -timezone CET -format {%Y-%m-%d %H:%M:%S %Z}]" } lappend res "#--" # backwards set base 1459044000 for {set i 0} {$i <= 3} {incr i} { - set d [clock scan "-$i hour" -base $base -timezone CET] - lappend res "$d = [clock format $d -timezone CET -format {%Y-%m-%d %H:%M:%S %Z}]" + set d [clock scan "-$i hour" -base $base -timezone CET] + lappend res "$d = [clock format $d -timezone CET -format {%Y-%m-%d %H:%M:%S %Z}]" } set res } [split [regsub -all {^\n|\n$} { @@ -36804,15 +36804,15 @@ test clock-34.70.2 {check date in DST-hole: daylight switch CEST -> CET} { # forwards set base 1477782000 for {set i 0} {$i <= 3} {incr i} { - set d [clock scan "+$i hour" -base $base -timezone CET] - lappend res "$d = [clock format $d -timezone CET -format {%Y-%m-%d %H:%M:%S %Z}]" + set d [clock scan "+$i hour" -base $base -timezone CET] + lappend res "$d = [clock format $d -timezone CET -format {%Y-%m-%d %H:%M:%S %Z}]" } lappend res "#--" # backwards set base 1477792800 for {set i 0} {$i <= 3} {incr i} { - set d [clock scan "-$i hour" -base $base -timezone CET] - lappend res "$d = [clock format $d -timezone CET -format {%Y-%m-%d %H:%M:%S %Z}]" + set d [clock scan "-$i hour" -base $base -timezone CET] + lappend res "$d = [clock format $d -timezone CET -format {%Y-%m-%d %H:%M:%S %Z}]" } set res } [split [regsub -all {^\n|\n$} { diff --git a/tests/cmdAH.test b/tests/cmdAH.test index eb2298e..bf695c2 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -1289,15 +1289,15 @@ test cmdAH-16.1 {Tcl_FileObjCmd: readable} { } test cmdAH-16.2 {Tcl_FileObjCmd: readable} { -constraints testchmod - -setup {testchmod 0o444 $gorpfile} - -body {file readable $gorpfile} - -result 1 + -setup {testchmod 0o444 $gorpfile} + -body {file readable $gorpfile} + -result 1 } test cmdAH-16.3 {Tcl_FileObjCmd: readable} { -constraints {unix notRoot testchmod notWsl} - -setup {testchmod 0o333 $gorpfile} - -body {file readable $gorpfile} - -result 0 + -setup {testchmod 0o333 $gorpfile} + -body {file readable $gorpfile} + -result 0 } # writable @@ -1308,15 +1308,15 @@ test cmdAH-17.1 {Tcl_FileObjCmd: writable} { } test cmdAH-17.2 {Tcl_FileObjCmd: writable} { -constraints {notRoot testchmod} - -setup {testchmod 0o555 $gorpfile} - -body {file writable $gorpfile} - -result 0 + -setup {testchmod 0o555 $gorpfile} + -body {file writable $gorpfile} + -result 0 } test cmdAH-17.3 {Tcl_FileObjCmd: writable} { -constraints testchmod - -setup {testchmod 0o222 $gorpfile} - -body {file writable $gorpfile} - -result 1 + -setup {testchmod 0o222 $gorpfile} + -body {file writable $gorpfile} + -result 1 } # executable diff --git a/tests/expr.test b/tests/expr.test index 658f9d1..d1ee99d 100644 --- a/tests/expr.test +++ b/tests/expr.test @@ -804,19 +804,19 @@ test expr-20.7 {handling of compile error in runtime case} { } {1 foo} # Test for non-numeric boolean literal handling -test expr-21.1 {non-numeric boolean literals} {expr false } false -test expr-21.2 {non-numeric boolean literals} {expr true } true -test expr-21.3 {non-numeric boolean literals} {expr off } off -test expr-21.4 {non-numeric boolean literals} {expr on } on -test expr-21.5 {non-numeric boolean literals} {expr no } no -test expr-21.6 {non-numeric boolean literals} {expr yes } yes -test expr-21.7 {non-numeric boolean literals} {expr !false} 1 -test expr-21.8 {non-numeric boolean literals} {expr !true } 0 -test expr-21.9 {non-numeric boolean literals} {expr !off } 1 -test expr-21.10 {non-numeric boolean literals} {expr !on } 0 -test expr-21.11 {non-numeric boolean literals} {expr !no } 1 -test expr-21.12 {non-numeric boolean literals} {expr !yes } 0 -test expr-21.13 {non-numeric boolean literals} -body { +test expr-21.1 {non-numeric boolean literals} {expr false } false +test expr-21.2 {non-numeric boolean literals} {expr true } true +test expr-21.3 {non-numeric boolean literals} {expr off } off +test expr-21.4 {non-numeric boolean literals} {expr on } on +test expr-21.5 {non-numeric boolean literals} {expr no } no +test expr-21.6 {non-numeric boolean literals} {expr yes } yes +test expr-21.7 {non-numeric boolean literals} {expr !false} 1 +test expr-21.8 {non-numeric boolean literals} {expr !true } 0 +test expr-21.9 {non-numeric boolean literals} {expr !off } 1 +test expr-21.10 {non-numeric boolean literals} {expr !on } 0 +test expr-21.11 {non-numeric boolean literals} {expr !no } 1 +test expr-21.12 {non-numeric boolean literals} {expr !yes } 0 +test expr-21.13 {non-numeric boolean literals} -body { expr !truef } -returnCodes error -match glob -result * test expr-21.14 {non-numeric boolean literals} { diff --git a/tests/fileSystem.test b/tests/fileSystem.test index 5ee95d9..f2273ba 100644 --- a/tests/fileSystem.test +++ b/tests/fileSystem.test @@ -34,8 +34,8 @@ catch { } # Test for commands defined in tcl::test package -testConstraint testfilesystem [llength [info commands ::testfilesystem]] -testConstraint testsetplatform [llength [info commands ::testsetplatform]] +testConstraint testfilesystem [llength [info commands ::testfilesystem]] +testConstraint testsetplatform [llength [info commands ::testsetplatform]] testConstraint testsimplefilesystem [llength [info commands ::testsimplefilesystem]] # Some things fail under all Continuous Integration systems for subtle reasons # such as CI often running with elevated privileges in a container. diff --git a/tests/for.test b/tests/for.test index 26300ce..d60c03e 100644 --- a/tests/for.test +++ b/tests/for.test @@ -205,7 +205,7 @@ test for-2.6 {continue tests, long command body} { } {1 3} test for-2.7 {continue tests, uncompiled [for]} -body { set file [makeFile { - set guard 0 + set guard 0 for {set i 20} {$i > 0} {incr i -1} { if {[incr guard]>30} {return BAD} continue diff --git a/tests/internals.tcl b/tests/internals.tcl index ff68c0f..17be320 100644 --- a/tests/internals.tcl +++ b/tests/internals.tcl @@ -79,7 +79,7 @@ proc testWithLimit args { } if { ( [info exists in(-warn-on-code)] && $ret in $in(-warn-on-code) ) || ( $ret && [info exists in(-warn-on-alloc-error)] && $in(-warn-on-alloc-error) - && [regexp {\munable to (?:re)?alloc\M} $result] ) + && [regexp {\munable to (?:re)?alloc\M} $result] ) } { tcltest::Warn "testWithLimit: wrong limit, result: $result" tcltest::Skip testWithLimit diff --git a/tests/io.test b/tests/io.test index a95a154..5e735d3 100644 --- a/tests/io.test +++ b/tests/io.test @@ -1791,6 +1791,32 @@ test io-13.12 {TranslateInputEOL: find EOF char in src} { close $f set x } "\n\n\nab\n\nd" +test io-13.13 {Translation crlf: \r followed by encoding error before buffer boundary - TCL bug 73bb42fb}\ +-setup { + set buffersize 8 + writeFile $path(test1) binary\ + [string repeat x [expr $buffersize-1]]\r\xe9XXXXXXXXXXXXXXXXXXXXXXXX +} -body { + set fd [open $path(test1)] + fconfigure $fd -profile strict -encoding utf-8 -buffersize [expr {$buffersize+1}] -translation crlf + catch {read $fd $buffersize} e d + list [dict get $d -data] [dict get $d -code] [dict get $d -errorcode] +} -cleanup { + close $fd +} -result {xxxxxxx 1 {POSIX EILSEQ {invalid or incomplete multibyte or wide character}}} +test io-13.14 {Translation crlf: \r followed by encoding error after buffer boundary - TCL bug 73bb42fb (crash)}\ +-setup { + set buffersize 8 + writeFile $path(test1) binary\ + [string repeat x [expr $buffersize-1]]\r\xe9XXXXXXXXXXXXXXXXXXXXXXXX +} -body { + set fd [open $path(test1)] + fconfigure $fd -profile strict -encoding utf-8 -buffersize $buffersize -translation crlf + catch {read $fd $buffersize} e d + list [dict get $d -data] [dict get $d -code] [dict get $d -errorcode] +} -cleanup { + close $fd +} -result {xxxxxxx 1 {POSIX EILSEQ {invalid or incomplete multibyte or wide character}}} # Test standard handle management. The functions tested are # Tcl_SetStdChannel and Tcl_GetStdChannel. Incidentally we are diff --git a/tests/ioCmd.test b/tests/ioCmd.test index fe4a02b..27e8e77 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -4142,7 +4142,7 @@ test iocmd.foreachLine-2.4 "foreachLine procedure: behaviour" -setup { set f [makeFile "a\nbb\nccc\ndd\ne" foreachLine24.txt] } -body { apply {filename { - set lines {} + set lines {} foreachLine var $filename { if {[string length $var] > 2} { return $var diff --git a/tests/lmap.test b/tests/lmap.test index f1cbd4b..823cdee 100644 --- a/tests/lmap.test +++ b/tests/lmap.test @@ -149,17 +149,17 @@ test lmap-3.1 {continue tests} { test lmap-3.2 {continue tests} { set x 0 list [lmap i {a b c d} { - incr x - if {[string compare $i "b"] != 0} continue - set i + incr x + if {[string compare $i "b"] != 0} continue + set i }] $x } {b 4} test lmap-3.3 {break tests} { set x 0 list [lmap i {a b c d} { incr x - if {[string compare $i "c"] == 0} break - set i + if {[string compare $i "c"] == 0} break + set i }] $x } {{a b} 3} # Check for bug similar to #406709 diff --git a/tests/msgcat.test b/tests/msgcat.test index 109ac82..b9fe7e3 100644 --- a/tests/msgcat.test +++ b/tests/msgcat.test @@ -1057,7 +1057,7 @@ if {[package vsatisfies [package provide msgcat] 1.7]} { test msgcat-14.1 {invocation loadcmd} -setup { mcforgetpackage - mclocale $locale + mclocale $locale mclocale "" mcloadedlocales clear set resultvariable "" @@ -1071,7 +1071,7 @@ if {[package vsatisfies [package provide msgcat] 1.7]} { test msgcat-14.2 {invocation failed in loadcmd} -setup { mcforgetpackage - mclocale $locale + mclocale $locale mclocale "" mcloadedlocales clear } -cleanup { @@ -1089,7 +1089,7 @@ if {[package vsatisfies [package provide msgcat] 1.7]} { test msgcat-14.3 {invocation changecmd} -setup { mcforgetpackage - mclocale $locale + mclocale $locale mclocale "" set resultvariable "" } -cleanup { @@ -1102,7 +1102,7 @@ if {[package vsatisfies [package provide msgcat] 1.7]} { test msgcat-14.4 {invocation unknowncmd} -setup { mcforgetpackage - mclocale $locale + mclocale $locale mclocale "" mcloadedlocales clear set resultvariable "" @@ -1117,7 +1117,7 @@ if {[package vsatisfies [package provide msgcat] 1.7]} { test msgcat-14.5 {disable global unknowncmd} -setup { mcforgetpackage - mclocale $locale + mclocale $locale mclocale "" mcloadedlocales clear set resultvariable "" @@ -1137,7 +1137,7 @@ if {[package vsatisfies [package provide msgcat] 1.7]} { test msgcat-14.6 {unknowncmd failing} -setup { mcforgetpackage - mclocale $locale + mclocale $locale mclocale "" mcloadedlocales clear set resultvariable "" diff --git a/tests/namespace.test b/tests/namespace.test index 0a69afb..6bb060a 100644 --- a/tests/namespace.test +++ b/tests/namespace.test @@ -3363,7 +3363,7 @@ test namespace-55.2 {compiled ensembles inside safe interpreters (for safe sub-c interp create -safe si set code { proc test_comp_dict d { dict for {k v} $d {expr $v} } - regexp -inline {Command 1:(?:[^\n]*\n){1,5}} [::tcl::unsupported::disassemble proc test_comp_dict] + regexp -inline {Command 1:(?:[^\n]*\n){1,5}} [::tcl::unsupported::disassemble proc test_comp_dict] } } -body { set a [ eval $code] diff --git a/tests/ooUtil.test b/tests/ooUtil.test index 709089d..cfca685 100644 --- a/tests/ooUtil.test +++ b/tests/ooUtil.test @@ -549,7 +549,7 @@ test ooUtil-8.1 {TIP 567: call oo::define twice from metaclass constructor} -set } ::oo::class create B { superclass ::oo::class parent - constructor {{definitionScript ""}} { + constructor {{definitionScript ""}} { next $definitionScript next {superclass ::A} } diff --git a/tests/socket.test b/tests/socket.test index 2f71d7b..54bef46 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -253,7 +253,7 @@ if {$doTestsWithRemoteServer} { testConstraint doTestsWithRemoteServer $doTestsWithRemoteServer if {!$doTestsWithRemoteServer} { if {[string first s $::tcltest::verbose] >= 0} { - puts "Skipping tests with remote server. See tests/socket.test for" + puts "Skipping tests with remote server. See tests/socket.test for" puts "information on how to run remote server." puts "Reason for not doing remote tests: $noRemoteTestReason" } @@ -1499,7 +1499,7 @@ test socket_$af-11.9 {accept callback error} -constraints [list socket supported set peername [fconfigure $callerSocket -peername] set s [socket [lindex $peername 0] $port] close $s - } + } } msg]} then { close $s error $msg @@ -1888,7 +1888,7 @@ proc transf_test {{testmode transfer} {maxIter 1000} {maxTime 10000}} { set srvsock [socket -server {apply {{ch args} {close $ch}}} -myaddr $::localhost $port] # socket on windows has some issues yet (e. g. bug [b6d0d8cc2c]), so we simply decrease iteration count (to 1/4): if {$::tcl_platform(platform) eq "windows" && $maxIter > 50} { - set ::count [expr {$maxIter / 4 * 3 - 1}]; # bypass 3/4 iterations + set ::count [expr {$maxIter / 4 * 3 - 1}]; # bypass 3/4 iterations } } tcltest::DebugPuts 2 "== test \[$::localhost\]:$port $testmode ==" @@ -1942,7 +1942,7 @@ proc transf_test {{testmode transfer} {maxIter 1000} {maxTime 10000}} { vwait ::count if {![string is integer $::count]} { # if timeout just skip (test was successful until now): - if {$::count eq "TIMEOUT"} {::tcltest::Skip "timing issue"} + if {$::count eq "TIMEOUT"} {::tcltest::Skip "timing issue"} break } if {[incr ::count] >= $maxIter} break diff --git a/tests/switch.test b/tests/switch.test index 930f062..4693200 100644 --- a/tests/switch.test +++ b/tests/switch.test @@ -246,7 +246,7 @@ test switch-7.4 {"-" bodies} -body { test switch-8.1 {empty body} { set msg {} switch {2} { - 1 {set msg 1} + 1 {set msg 1} 2 {} default {set msg 2} } @@ -257,13 +257,13 @@ proc test_switch_body {} { test switch-8.2 {weird body text, variable} { set cmd {test_switch_body} switch Foo { - Foo $cmd + Foo $cmd } } {INVOKED} test switch-8.3 {weird body text, variable} { set cmd {test_switch_body} switch Foo { - Foo {$cmd} + Foo {$cmd} } } {INVOKED} diff --git a/tests/unixNotfy.test b/tests/unixNotfy.test index 8ab0edb..336913b 100644 --- a/tests/unixNotfy.test +++ b/tests/unixNotfy.test @@ -59,7 +59,7 @@ test unixNotfy-2.1 {Tcl_DeleteFileHandler} \ fileevent $f writable {set x 1} vwait x close $f - thread::create "thread::send [thread::id] {set x ok}" + thread::create "thread::send [thread::id] {set x ok}" vwait x set x } \ @@ -80,7 +80,7 @@ test unixNotfy-2.2 {Tcl_DeleteFileHandler} \ close $f1 vwait y close $f2 - thread::create "thread::send [thread::id] {set x ok}" + thread::create "thread::send [thread::id] {set x ok}" vwait x set x } \ diff --git a/tests/var.test b/tests/var.test index 5300adc..2d0fe05 100644 --- a/tests/var.test +++ b/tests/var.test @@ -1142,7 +1142,7 @@ test var-23.10 {array enumeration, delete key} -match glob -setup { try { array set a {a 1 b 2 c 3 d 4} array for {k v} a { - lappend reslist $k $v + lappend reslist $k $v if { $k eq "a" } { unset a(c) } @@ -1165,7 +1165,7 @@ test var-23.11 {array enumeration, insert key} -match glob -setup { try { array set a {a 1 b 2 c 3 d 4} array for {k v} a { - lappend reslist $k $v + lappend reslist $k $v if { $k eq "a" } { set a(e) 5 } -- cgit v0.12 From 504e8288245e1c8e6ec1b3cbda40da8ad841fa6f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 1 Feb 2025 22:06:40 +0000 Subject: Since TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE, those Tcl_InitStubs() variants are now obsolete --- generic/tcl.h | 13 ++----------- 1 file changed, 2 insertions(+), 11 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index dbf7d82..66c44ef 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2345,14 +2345,9 @@ void * TclStubCall(void *arg); (exact)|(TCL_MAJOR_VERSION<<8)|(0xFF<<16), \ TCL_STUB_MAGIC) # endif -#elif TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE -# define Tcl_InitStubs(interp, version, exact) \ - (Tcl_InitStubs)(interp, version, \ - (exact)|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16), \ - TCL_STUB_MAGIC) #else # define Tcl_InitStubs(interp, version, exact) \ - (Tcl_InitStubs)(interp, (((exact)&1) ? (version) : "9.0.0"), \ + (Tcl_InitStubs)(interp, version, \ (exact)|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16), \ TCL_STUB_MAGIC) #endif @@ -2361,14 +2356,10 @@ void * TclStubCall(void *arg); # define Tcl_InitStubs(interp, version, exact) \ Tcl_Panic(((void)interp, (void)version, \ (void)exact, "Please define -DUSE_TCL_STUBS")) -#elif TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE +#else # define Tcl_InitStubs(interp, version, exact) \ Tcl_PkgInitStubsCheck(interp, version, \ (exact)|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16)) -#else -# define Tcl_InitStubs(interp, version, exact) \ - Tcl_PkgInitStubsCheck(interp, TCL_PATCH_LEVEL, \ - 1|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16)) #endif #endif -- cgit v0.12 From 50891f3a2d9cac871854e32dd8e21258be0780e6 Mon Sep 17 00:00:00 2001 From: max Date: Tue, 4 Feb 2025 12:29:44 +0000 Subject: TclSubstOptions: Optimize the positive/negative detection logic (thanks, Rolf). Other minor refinements. --- generic/tclCmdMZ.c | 14 +++++--------- 1 file changed, 5 insertions(+), 9 deletions(-) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 012d1bc..71f2427 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -3343,29 +3343,25 @@ TclSubstOptions( enum { SUBST_NOBACKSLASHES, SUBST_NOCOMMANDS, SUBST_NOVARS, SUBST_BACKSLASHES, SUBST_COMMANDS, SUBST_VARS - }; + } optionIndex; int i, flags = TCL_SUBST_ALL; int positive = 0, negative = 0; for (i = 0; i < numOpts; i++) { - int optionIndex; - if (Tcl_GetIndexFromObj(interp, opts[i], substOptions, "option", 0, &optionIndex) != TCL_OK) { return TCL_ERROR; } - if (optionIndex >= SUBST_NOBACKSLASHES && - optionIndex <= SUBST_NOVARS) { + if (optionIndex <= SUBST_NOVARS) { negative = 1; - } else if (optionIndex >= SUBST_BACKSLASHES && - optionIndex <= SUBST_VARS && positive == 0) { + } else if (positive == 0) { positive = 1; - /* Swap the default at the first positive switch */ + /* Swap default at the first positive switch only */ flags = 0; } if (positive && negative) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "positive and negative switches cannot be combined", -1)); + "cannot combine positive and negative options", -1)); return TCL_ERROR; } switch (optionIndex) { -- cgit v0.12 From 2fcdb49939f9108f69a4369c5392bfb99f473be7 Mon Sep 17 00:00:00 2001 From: max Date: Tue, 4 Feb 2025 12:38:32 +0000 Subject: subst.test: Rearrange the new tests for positve options to subst into a single block. --- tests/subst.test | 38 +++++++++++++++++++------------------- 1 file changed, 19 insertions(+), 19 deletions(-) diff --git a/tests/subst.test b/tests/subst.test index 3c68ecb..4903fd1 100644 --- a/tests/subst.test +++ b/tests/subst.test @@ -130,47 +130,47 @@ test subst-7.2 {switches} -returnCodes error -body { test subst-7.3 {switches} -returnCodes error -body { subst -bogus bar } -result {bad option "-bogus": must be -nobackslashes, -nocommands, -novariables, -backslashes, -commands, or -variables} -test subst-7.4.1 {switches} { +test subst-7.4 {switches} { set x 123 subst -nobackslashes {abc $x [expr {1 + 2}] \\\x41} } {abc 123 3 \\\x41} -test subst-7.4.2 {switches} { - set x 123 - subst -commands -variables {abc $x [expr {1 + 2}] \\\x41} -} {abc 123 3 \\\x41} -test subst-7.5.1 {switches} { +test subst-7.5 {switches} { set x 123 subst -nocommands {abc $x [expr {1 + 2}] \\\x41} } {abc 123 [expr {1 + 2}] \A} -test subst-7.5.2 {switches} { - set x 123 - subst -backslashes -variables {abc $x [expr {1 + 2}] \\\x41} -} {abc 123 [expr {1 + 2}] \A} -test subst-7.6.1 {switches} { +test subst-7.6 {switches} { set x 123 subst -novariables {abc $x [expr {1 + 2}] \\\x41} } {abc $x 3 \A} -test subst-7.6.2 {switches} { - set x 123 - subst -backslashes -commands {abc $x [expr {1 + 2}] \\\x41} -} {abc $x 3 \A} 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 {switches} { +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 {switches} { +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 {switches} { +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.11 {switches} { +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} -- cgit v0.12 From 7826ad63b85121407bdcca99f12db74e529d8917 Mon Sep 17 00:00:00 2001 From: max Date: Tue, 4 Feb 2025 18:06:37 +0000 Subject: subst: Fix segfault when mixing positive and negative options and add a test case for it. --- generic/tclCmdMZ.c | 6 ++++-- tests/subst.test | 5 ++++- 2 files changed, 8 insertions(+), 3 deletions(-) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 71f2427..b501b30 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -3360,8 +3360,10 @@ TclSubstOptions( flags = 0; } if (positive && negative) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "cannot combine positive and negative options", -1)); + if (interp) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "cannot combine positive and negative options", -1)); + } return TCL_ERROR; } switch (optionIndex) { diff --git a/tests/subst.test b/tests/subst.test index 4903fd1..1eaa5dc 100644 --- a/tests/subst.test +++ b/tests/subst.test @@ -174,7 +174,10 @@ 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} -- cgit v0.12 From 8224b50079810d576aea3c7781112ecba6891c10 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 6 Feb 2025 07:38:37 +0000 Subject: Oops --- generic/tclDecls.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 767535a..c8f2eaf 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -4247,7 +4247,7 @@ extern const TclStubs *tclStubsPtr; #define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \ Tcl_GetBytesFromObj(NULL, (objPtr), (sizePtr)) -#if TCL_MINOR_VERSION > 1 +#if TCL_MINOR_VERSION < 1 # undef Tcl_IsEmpty #endif -- cgit v0.12 From 3d5fe1e294ddf9d7aac4d650fe11a4236679af61 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 6 Feb 2025 11:34:13 +0000 Subject: Fix [e086622a87]: WINE "env" test failures --- tests/env.test | 1 + tests/winFCmd.test | 12 ++++++------ 2 files changed, 7 insertions(+), 6 deletions(-) diff --git a/tests/env.test b/tests/env.test index b403d9a..8b3f1df 100644 --- a/tests/env.test +++ b/tests/env.test @@ -111,6 +111,7 @@ variable keep { ProgramFiles(x86) CommonProgramW6432 ProgramW6432 PROCESSOR_ARCHITECTURE PROCESSOR_ARCHITEW6432 USERPROFILE WINECONFIGDIR WINEDATADIR WINEDLLDIR0 WINEHOMEDIR + WINELOADER WINEUSERLOCALE WINEUSERNAME } variable printenvScript [makeFile [string map [list @keep@ [list $keep]] { diff --git a/tests/winFCmd.test b/tests/winFCmd.test index d8622a3..a2484da 100644 --- a/tests/winFCmd.test +++ b/tests/winFCmd.test @@ -206,7 +206,7 @@ test winFCmd-1.15 {TclpRenameFile: errno: EEXIST} -setup { } -constraints {win testfile} -body { createfile tf1 testfile mv tf1 nul -} -returnCodes error -result EEXIST +} -returnCodes error -result {^(ENODEV|EEXIST)$} -match regexp test winFCmd-1.16 {TclpRenameFile: MoveFile() != FALSE} -setup { cleanup } -constraints {win testfile} -body { @@ -250,9 +250,9 @@ test winFCmd-1.23 {TclpRenameFile: move dir into self} -setup { test winFCmd-1.24 {TclpRenameFile: move a root dir} -setup { cleanup } -constraints {win testfile} -body { - # Error code depends on Windows version + # Error code depends on Windows/WINE version testfile mv / c:/ -} -returnCodes error -result {^(EINVAL|ENOENT)$} -match regexp +} -returnCodes error -result {^(EINVAL|ENOENT|EEXIST)$} -match regexp test winFCmd-1.25 {TclpRenameFile: cross file systems} -setup { cleanup } -constraints {win cdrom testfile} -body { @@ -681,9 +681,9 @@ test winFCmd-6.11 {TclpRemoveDirectory: attr == -1} -setup { cleanup } -constraints {win testfile notInCIenv} -body { testfile rmdir / - # WinXP returns EEXIST, WinNT seems to return EACCES. No policy - # decision has been made as to which is correct. -} -returnCodes error -match regexp -result {^/ E(ACCES|EXIST)$} + # WinXP returns EEXIST, WinNT seems to return EACCES, WINE returns + # ENODEV. No policy decision has been made as to which is correct. +} -returnCodes error -match regexp -result {^/ E(ACCES|EXIST|NODEV)$} test winFCmd-6.13 {TclpRemoveDirectory: write-protected} -setup { cleanup } -constraints {win testfile testchmod notInCIenv} -body { -- cgit v0.12 From 2813cf5bec949aea927ba2fea207ec499bc8c7da Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Thu, 6 Feb 2025 17:33:11 +0000 Subject: Throwaway test function for Tcl_IsEmpty --- generic/tclTestObj.c | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index f73483b..d71b258 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); @@ -1829,6 +1832,21 @@ CheckIfVarUnset( } /* + * Throw-away illustrative case to illustrate Tcl_IsEmpty bug + * No error checks etc... + */ +static int +TestisemptyCmd ( + TCL_UNUSED(void *), + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_IsEmpty(objv[1]))); + return TCL_OK; +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 -- cgit v0.12 From 9e6350deb8b550923293abba2e18582483d56356 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 6 Feb 2025 22:21:00 +0000 Subject: Change implementation, based on community feedback --- doc/StringObj.3 | 4 ++-- generic/tclListObj.c | 4 ++-- generic/tclStringObj.c | 8 ++++---- 3 files changed, 8 insertions(+), 8 deletions(-) diff --git a/doc/StringObj.3 b/doc/StringObj.3 index 5d6a90d..f903912 100644 --- a/doc/StringObj.3 +++ b/doc/StringObj.3 @@ -406,8 +406,8 @@ 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 -NULL, 1 if \fIobjPtr\fR is the empty string, 0 otherwise. +The \fBTcl_IsEmpty\fR function returns 1 if \fIobjPtr\fR is the empty +string, 0 otherwise. It doesn't generate the string representation (unless the type is unknown), so it can safely be called on lists with billions of elements, or any other data structure for which diff --git a/generic/tclListObj.c b/generic/tclListObj.c index b8586d3..36914bc 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -1970,7 +1970,7 @@ Tcl_ListObjIndex( Tcl_Size numElems; /* Empty string => empty list. Avoid unnecessary shimmering */ - if (Tcl_IsEmpty(listObj)) { + if (listObj->bytes == &tclEmptyString) { *objPtrPtr = NULL; return TCL_OK; } @@ -2024,7 +2024,7 @@ Tcl_ListObjLength( ListRep listRep; /* Empty string => empty list. Avoid unnecessary shimmering */ - if (Tcl_IsEmpty(listObj)) { + if (listObj->bytes == &tclEmptyString) { *lenPtr = 0; return TCL_OK; } diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 3204a24..0381e88 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -1390,7 +1390,7 @@ Tcl_AppendObjToObj( } if (TclIsPureByteArray(appendObjPtr) - && (TclIsPureByteArray(objPtr) || Tcl_IsEmpty(objPtr))) { + && (TclIsPureByteArray(objPtr) || objPtr->bytes == &tclEmptyString)) { /* * Both bytearray objects are pure, so the second internal bytearray value * can be appended to the first, with no need to modify the "bytes" field. @@ -4384,10 +4384,10 @@ Tcl_IsEmpty( Tcl_Obj *objPtr) { if (objPtr == NULL) { - return -1; + Tcl_Panic("%s: objPtr is NULL", "Tcl_IsEmpty"); } - if (objPtr->bytes && !objPtr->length) { - return 1; + if (objPtr->bytes) { + return !objPtr->length; } if (TclHasInternalRep(objPtr, &tclDictType)) { /* Since "dict" doesn't have a lengthProc */ -- cgit v0.12 From c15c44eab1cb8d684bf29d87461e49579933c926 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 6 Feb 2025 22:54:48 +0000 Subject: Slightly better: less code duplication --- generic/tclStringObj.c | 25 ++++++++++++------------- 1 file changed, 12 insertions(+), 13 deletions(-) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 0381e88..ec6fa0a 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -4386,21 +4386,20 @@ Tcl_IsEmpty( if (objPtr == NULL) { Tcl_Panic("%s: objPtr is NULL", "Tcl_IsEmpty"); } - if (objPtr->bytes) { - return !objPtr->length; - } - if (TclHasInternalRep(objPtr, &tclDictType)) { - /* Since "dict" doesn't have a lengthProc */ - Tcl_Size size; - Tcl_DictObjSize(NULL, objPtr, &size); - return !size; - } + 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); + Tcl_ObjTypeLengthProc *proc = TclObjTypeHasProc(objPtr, lengthProc); + if (proc != NULL) { + return !proc(objPtr); + } + (void)TclGetString(objPtr); } - (void)TclGetString(objPtr); return !objPtr->length; } -- cgit v0.12 From d15b99669ee6a7cfcc12ef109255c7de3be8fba1 Mon Sep 17 00:00:00 2001 From: sebres Date: Sat, 8 Feb 2025 13:40:32 +0000 Subject: amend to [5a28eecf3519c645]: reset cmpPtr->clientData (it must be not cmpPtr, since cmpPtr->proc is not InvokeObjectCommand anymore) --- generic/tclBasic.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 3b757bb..6c73ed0 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -1131,7 +1131,7 @@ Tcl_CreateInterp(void) cmdPtr->cmdEpoch = 0; cmdPtr->compileProc = cmdInfoPtr->compileProc; cmdPtr->proc = NULL; - cmdPtr->clientData = cmdPtr; + cmdPtr->clientData = NULL; cmdPtr->objProc = cmdInfoPtr->objProc; cmdPtr->objClientData = NULL; cmdPtr->deleteProc = NULL; @@ -2946,7 +2946,7 @@ TclCreateObjCommandInNs( cmdPtr->objProc = proc; cmdPtr->objClientData = clientData; cmdPtr->proc = NULL; - cmdPtr->clientData = cmdPtr; + cmdPtr->clientData = NULL; cmdPtr->deleteProc = deleteProc; cmdPtr->deleteData = clientData; cmdPtr->flags = 0; -- cgit v0.12 From 1ad46af73b4569950453b9820edc99d3388f66d5 Mon Sep 17 00:00:00 2001 From: sebres Date: Mon, 10 Feb 2025 10:24:31 +0000 Subject: simplify detection of combination for positive and negative options --- generic/tclCmdMZ.c | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index ac0b284..76468b2 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -3359,14 +3359,14 @@ TclSubstOptions( } flags |= optionFlags[optionIndex]; } - if ((flags & TCL_SUBST_ALL) && (flags & (TCL_SUBST_ALL << 16))) { - if (interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "cannot combine positive and negative options", -1)); + 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; } - return TCL_ERROR; - } - if (flags >> 16) { /* mask default flags using negative options */ flags = TCL_SUBST_ALL & ~(flags >> 16); } -- cgit v0.12 From d78d450df4f34471dac0af06fe8c89e6d2f69b75 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Tue, 11 Feb 2025 16:43:26 +0000 Subject: Remove duplicate documentation of tcl_wordchars and tcl_nonwordchars --- doc/library.n | 8 +++----- doc/tclvars.n | 20 +------------------- 2 files changed, 4 insertions(+), 24 deletions(-) diff --git a/doc/library.n b/doc/library.n index af9d776..0bad31a 100644 --- a/doc/library.n +++ b/doc/library.n @@ -9,7 +9,7 @@ .so man.macros .BS .SH NAME -auto_execok, auto_import, auto_load, auto_mkindex, auto_qualify, auto_reset, foreachLine, parray, readFile, tcl_findLibrary, tcl_endOfWord, tcl_startOfNextWord, tcl_startOfPreviousWord, tcl_wordBreakAfter, tcl_wordBreakBefore, writeFile \- standard library of Tcl procedures +auto_execok, auto_import, auto_load, auto_mkindex, auto_qualify, auto_reset, foreachLine, parray, readFile, tcl_findLibrary, tcl_endOfWord, tcl_nonwordchars, tcl_startOfNextWord, tcl_startOfPreviousWord, tcl_wordBreakAfter, tcl_wordBreakBefore, tcl_wordchars, writeFile \- standard library of Tcl procedures .SH SYNOPSIS .nf \fBauto_execok \fIcmd\fR @@ -473,8 +473,7 @@ These variables are only used in the \fBtcl_endOfWord\fR, This variable contains a regular expression that is used by routines like \fBtcl_endOfWord\fR to identify whether a character is part of a word or not. If the pattern matches a character, the character is -considered to be a non-word character. The default value is -.QW "\\W" . +considered to be a non-word character. The default value is \fB\eW\fR. .\" VARIABLE: tcl_wordchars .TP \fBtcl_wordchars\fR @@ -482,8 +481,7 @@ considered to be a non-word character. The default value is This variable contains a regular expression that is used by routines like \fBtcl_endOfWord\fR to identify whether a character is part of a word or not. If the pattern matches a character, the character is -considered to be a word character. The default value is -.QW "\\w" . +considered to be a word character. The default value is \fB\ew\fR. .SH "SEE ALSO" env(n), info(n), re_syntax(n) .SH KEYWORDS diff --git a/doc/tclvars.n b/doc/tclvars.n index fbbe956..73d56da 100644 --- a/doc/tclvars.n +++ b/doc/tclvars.n @@ -10,7 +10,7 @@ .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME -argc, argv, argv0, auto_path, env, errorCode, errorInfo, tcl_interactive, tcl_library, tcl_nonwordchars, tcl_patchLevel, tcl_pkgPath, tcl_platform, tcl_rcFileName, tcl_traceCompile, tcl_traceExec, tcl_wordchars, tcl_version \- Variables used by Tcl +argc, argv, argv0, auto_path, env, errorCode, errorInfo, tcl_interactive, tcl_library, tcl_patchLevel, tcl_pkgPath, tcl_platform, tcl_rcFileName, tcl_traceCompile, tcl_traceExec, tcl_version \- Variables used by Tcl .BE .SH DESCRIPTION .PP @@ -390,24 +390,6 @@ and interpreter. This variable and functionality only exist if \fBTCL_COMPILE_DEBUG\fR was defined during Tcl's compilation. .RE -.\" VARIABLE: tcl_wordchars -.TP -\fBtcl_wordchars\fR -. -The value of this variable is a regular expression that can be set to -control what are considered -.QW word -characters. It defaults to \fB\ew\fR, which is any Unicode -word character (number, letter, or underscore). -.\" VARIABLE: tcl_nonwordchars -.TP -\fBtcl_nonwordchars\fR -. -The value of this variable is a regular expression that can be set to -control what are considered -.QW non-word -characters. It defaults to \fB\eW\fR, which is anything but a -Unicode word character (number, letter, or underscore). .\" VARIABLE: tcl_version .TP \fBtcl_version\fR -- cgit v0.12 From e83d3cd4909ea9b00e4daac97a02a19507dced7c Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Tue, 11 Feb 2025 17:09:12 +0000 Subject: Bug f5d0e75a49 - correct tcl::process documentation for non-subprocesses --- doc/process.n | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/doc/process.n b/doc/process.n index 5124b46..b34deb2 100644 --- a/doc/process.n +++ b/doc/process.n @@ -41,17 +41,19 @@ corresponding process table entries purged. \fB::tcl::process purge\fR ?\fIpids\fR? . Cleans up all data associated with terminated subprocesses. If \fIpids\fR is -specified as a list of PIDs then the command only cleanup data for the matching -subprocesses if they exist, and raises an error otherwise. If a process listed is +specified as a list of PIDs then the command only cleans up data for the matching +subprocesses if they exist. If a process listed is still active, this command does nothing to that process. +Any PID that does not correspond to a subprocess is ignored. .\" METHOD: status .TP \fB::tcl::process status\fR ?\fIswitches\fR? ?\fIpids\fR? . Returns a dictionary mapping subprocess PIDs to their respective status. If \fIpids\fR is specified as a list of PIDs then the command only returns the -status of the matching subprocesses if they exist, and raises an error -otherwise. For active processes, the status is an empty value. For terminated +status of the matching subprocesses if they exist. +Any PID that does not correspond to a subprocess is ignored. +For active processes, the status is an empty value. For terminated processes, the status is a list with the following format: .QW "\fB{\fIcode\fR ?\fImsg errorCode\fR?\fB}\fR" , where: -- cgit v0.12 From e18563a329d161f84dca1c69ea833f6f59e9eba7 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 11 Feb 2025 17:11:48 +0000 Subject: Swap from deprecated build image to current one --- .github/workflows/onefiledist.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/onefiledist.yml b/.github/workflows/onefiledist.yml index 3401c1b..f64c22a 100644 --- a/.github/workflows/onefiledist.yml +++ b/.github/workflows/onefiledist.yml @@ -11,7 +11,7 @@ permissions: jobs: linux: name: Linux - runs-on: ubuntu-20.04 + runs-on: ubuntu-22.04 defaults: run: shell: bash -- cgit v0.12 From 8818b6037b66523c63605a7da1834d5307f731b0 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 11 Feb 2025 21:44:15 +0000 Subject: Don't worry building for Tcl 8.7 any more --- .github/workflows/linux-build.yml | 3 +-- .github/workflows/mac-build.yml | 3 +-- .github/workflows/onefiledist.yml | 2 +- .github/workflows/win-build.yml | 3 +-- 4 files changed, 4 insertions(+), 7 deletions(-) diff --git a/.github/workflows/linux-build.yml b/.github/workflows/linux-build.yml index 2e6784d..975b1fa 100644 --- a/.github/workflows/linux-build.yml +++ b/.github/workflows/linux-build.yml @@ -3,8 +3,7 @@ on: push: branches: - "main" - - "core-8-branch" - - "core-8-6-branch" + - "core-9-0-branch" tags: - "core-**" permissions: diff --git a/.github/workflows/mac-build.yml b/.github/workflows/mac-build.yml index e33b12a..df907d9 100644 --- a/.github/workflows/mac-build.yml +++ b/.github/workflows/mac-build.yml @@ -3,8 +3,7 @@ on: push: branches: - "main" - - "core-8-branch" - - "core-8-6-branch" + - "core-9-0-branch" tags: - "core-**" permissions: diff --git a/.github/workflows/onefiledist.yml b/.github/workflows/onefiledist.yml index f64c22a..a914932 100644 --- a/.github/workflows/onefiledist.yml +++ b/.github/workflows/onefiledist.yml @@ -3,7 +3,7 @@ on: push: branches: - "main" - - "core-8-branch" + - "core-9-0-branch" tags: - "core-**" permissions: diff --git a/.github/workflows/win-build.yml b/.github/workflows/win-build.yml index aff5008..24c5385 100644 --- a/.github/workflows/win-build.yml +++ b/.github/workflows/win-build.yml @@ -3,8 +3,7 @@ on: push: branches: - "main" - - "core-8-branch" - - "core-8-6-branch" + - "core-9-0-branch" tags: - "core-**" permissions: -- cgit v0.12 From cea29dc862927d59885d2b5c560fa7ca71130681 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 12 Feb 2025 08:01:16 +0000 Subject: More accurate documentation --- doc/StringObj.3 | 4 ++-- generic/tclStringObj.c | 7 ++++--- 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/doc/StringObj.3 b/doc/StringObj.3 index f903912..92775f7 100644 --- a/doc/StringObj.3 +++ b/doc/StringObj.3 @@ -408,8 +408,8 @@ 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 the -type is unknown), so it can safely be called on lists with +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" diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index ec6fa0a..b3e6dec 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -4366,15 +4366,16 @@ ExtendUnicodeRepWithString( * * Tcl_IsEmpty -- * - * Check whether the obj is empty. + * Check whether the obj is the empty string. * * Results: - * -1 if the obj is NULL * 1 if the obj is "" * 0 otherwise * * Side effects: - * String representation is generated if the obj has no lengthProc + * If there is no other way to determine whethere the string + * representation is the empty string, the string representation + * is generated. * *---------------------------------------------------------------------- */ -- cgit v0.12 From ebb36f685d266794326293792675a46282c122c1 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 12 Feb 2025 08:22:48 +0000 Subject: Don't worry building for Tcl 8.7 any more --- .github/workflows/linux-build.yml | 3 +-- .github/workflows/mac-build.yml | 3 +-- .github/workflows/onefiledist.yml | 4 ++-- .github/workflows/win-build.yml | 3 +-- 4 files changed, 5 insertions(+), 8 deletions(-) diff --git a/.github/workflows/linux-build.yml b/.github/workflows/linux-build.yml index 2e6784d..975b1fa 100644 --- a/.github/workflows/linux-build.yml +++ b/.github/workflows/linux-build.yml @@ -3,8 +3,7 @@ on: push: branches: - "main" - - "core-8-branch" - - "core-8-6-branch" + - "core-9-0-branch" tags: - "core-**" permissions: diff --git a/.github/workflows/mac-build.yml b/.github/workflows/mac-build.yml index e33b12a..df907d9 100644 --- a/.github/workflows/mac-build.yml +++ b/.github/workflows/mac-build.yml @@ -3,8 +3,7 @@ on: push: branches: - "main" - - "core-8-branch" - - "core-8-6-branch" + - "core-9-0-branch" tags: - "core-**" permissions: diff --git a/.github/workflows/onefiledist.yml b/.github/workflows/onefiledist.yml index 542221d..9520138 100644 --- a/.github/workflows/onefiledist.yml +++ b/.github/workflows/onefiledist.yml @@ -3,7 +3,7 @@ on: push: branches: - "main" - - "core-8-branch" + - "core-9-0-branch" tags: - "core-**" permissions: @@ -11,7 +11,7 @@ permissions: jobs: linux: name: Linux - runs-on: ubuntu-20.04 + runs-on: ubuntu-22.04 defaults: run: shell: bash diff --git a/.github/workflows/win-build.yml b/.github/workflows/win-build.yml index aff5008..24c5385 100644 --- a/.github/workflows/win-build.yml +++ b/.github/workflows/win-build.yml @@ -3,8 +3,7 @@ on: push: branches: - "main" - - "core-8-branch" - - "core-8-6-branch" + - "core-9-0-branch" tags: - "core-**" permissions: -- cgit v0.12 From f8e065e3e2aa864122529167bff82b75811dcedc Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 17 Feb 2025 14:44:20 +0000 Subject: Remove references to ancient TIP's --- doc/Cancel.3 | 3 +-- doc/Ensemble.3 | 2 -- doc/Namespace.3 | 3 --- doc/chan.n | 8 +++----- doc/copy.n | 2 -- doc/file.n | 1 - doc/library.n | 8 +++----- doc/lreplace.n | 4 ---- doc/tclvars.n | 21 +-------------------- doc/tm.n | 4 ++-- doc/zlib.n | 12 ------------ 11 files changed, 10 insertions(+), 58 deletions(-) diff --git a/doc/Cancel.3 b/doc/Cancel.3 index 72dd939..e9b497a 100644 --- a/doc/Cancel.3 +++ b/doc/Cancel.3 @@ -77,7 +77,6 @@ object is shared with some other location (including the Tcl evaluation stack) it should have its reference count incremented before calling this function. .SH "SEE ALSO" -interp(n), Tcl_Eval(3), -TIP 285 +interp(n), Tcl_Eval(3) .SH KEYWORDS cancel, unwind diff --git a/doc/Ensemble.3 b/doc/Ensemble.3 index 0c2ea9d..f31049f 100644 --- a/doc/Ensemble.3 +++ b/doc/Ensemble.3 @@ -4,8 +4,6 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" This documents the C API introduced in TIP#235 -'\" .TH Tcl_Ensemble 3 8.5 Tcl "Tcl Library Procedures" .so man.macros .BS diff --git a/doc/Namespace.3 b/doc/Namespace.3 index 399bd7d..4b74d47 100644 --- a/doc/Namespace.3 +++ b/doc/Namespace.3 @@ -4,9 +4,6 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" Note that some of these functions do not seem to belong, but they -'\" were all introduced with the same TIP (#139) -'\" .TH Tcl_Namespace 3 8.5 Tcl "Tcl Library Procedures" .so man.macros .BS diff --git a/doc/chan.n b/doc/chan.n index ef965e5..808312e 100644 --- a/doc/chan.n +++ b/doc/chan.n @@ -90,14 +90,12 @@ the Tcl program. .PP Channels are automatically closed when an interpreter is destroyed and when the process exits. -From 8.6 on (TIP#398), nonblocking channels are no longer switched to +Nonblocking channels are not switched to blocking mode when exiting; this guarantees a timely exit even when the peer or a communication channel is stalled. To ensure proper flushing of -stalled nonblocking channels on exit, one must now either (a) actively +stalled nonblocking channels on exit, one must either (a) actively switch them back to blocking or (b) use the environment variable -\fBTCL_FLUSH_NONBLOCKING_ON_EXIT\fR, which when set and not equal to -.QW \fB0\fR -restores the previous behavior. +\fBTCL_FLUSH_NONBLOCKING_ON_EXIT\fR. .RE .\" METHOD: configure .TP diff --git a/doc/copy.n b/doc/copy.n index 56160a0..46b3c78 100644 --- a/doc/copy.n +++ b/doc/copy.n @@ -24,7 +24,6 @@ name of the object or class to be copied, \fIsourceObject\fR, and optionally the name of the object or class to create, \fItargetObject\fR, which will be resolved relative to the current namespace if not an absolute qualified name and -.VS TIP473 \fItargetNamespace\fR which is the name of the namespace that will hold the internal state of the object (\fBmy\fR command, etc.); it \fImust not\fR refer to an existing namespace. @@ -32,7 +31,6 @@ If either \fItargetObject\fR or \fItargetNamespace\fR is omitted or is given as the empty string, a new name is chosen. Names, unless specified, are chosen with the same algorithm used by the \fBnew\fR method of \fBoo::class\fR. -.VE TIP473 The copied object will be of the same class as the source object, and will have all its per-object methods copied. If it is a class, it will also have all the class methods in the class copied, but it will not have any of its instances diff --git a/doc/file.n b/doc/file.n index 6d213a2..b306976 100644 --- a/doc/file.n +++ b/doc/file.n @@ -564,7 +564,6 @@ between platforms: .\" METHOD: tempfile .TP \fBfile tempfile\fR ?\fInameVar\fR? ?\fItemplate\fR? -.\" TIP #210 Creates a temporary file and returns a read-write channel opened on that file. If the \fInameVar\fR is given, it specifies a variable that the name of the temporary file will be written into; if absent, Tcl will attempt to arrange diff --git a/doc/library.n b/doc/library.n index af9d776..0bad31a 100644 --- a/doc/library.n +++ b/doc/library.n @@ -9,7 +9,7 @@ .so man.macros .BS .SH NAME -auto_execok, auto_import, auto_load, auto_mkindex, auto_qualify, auto_reset, foreachLine, parray, readFile, tcl_findLibrary, tcl_endOfWord, tcl_startOfNextWord, tcl_startOfPreviousWord, tcl_wordBreakAfter, tcl_wordBreakBefore, writeFile \- standard library of Tcl procedures +auto_execok, auto_import, auto_load, auto_mkindex, auto_qualify, auto_reset, foreachLine, parray, readFile, tcl_findLibrary, tcl_endOfWord, tcl_nonwordchars, tcl_startOfNextWord, tcl_startOfPreviousWord, tcl_wordBreakAfter, tcl_wordBreakBefore, tcl_wordchars, writeFile \- standard library of Tcl procedures .SH SYNOPSIS .nf \fBauto_execok \fIcmd\fR @@ -473,8 +473,7 @@ These variables are only used in the \fBtcl_endOfWord\fR, This variable contains a regular expression that is used by routines like \fBtcl_endOfWord\fR to identify whether a character is part of a word or not. If the pattern matches a character, the character is -considered to be a non-word character. The default value is -.QW "\\W" . +considered to be a non-word character. The default value is \fB\eW\fR. .\" VARIABLE: tcl_wordchars .TP \fBtcl_wordchars\fR @@ -482,8 +481,7 @@ considered to be a non-word character. The default value is This variable contains a regular expression that is used by routines like \fBtcl_endOfWord\fR to identify whether a character is part of a word or not. If the pattern matches a character, the character is -considered to be a word character. The default value is -.QW "\\w" . +considered to be a word character. The default value is \fB\ew\fR. .SH "SEE ALSO" env(n), info(n), re_syntax(n) .SH KEYWORDS diff --git a/doc/lreplace.n b/doc/lreplace.n index 47d33f9..6f3fda4 100644 --- a/doc/lreplace.n +++ b/doc/lreplace.n @@ -31,12 +31,10 @@ list, and \fBend\fR refers to the last element of the list. If either \fIfirst\fR or \fIlast\fR is less than zero, it is considered to refer to before the first element of the list. This allows \fBlreplace\fR to prepend elements to \fIlist\fR. -.VS TIP505 If either \fIfirst\fR or \fIlast\fR indicates a position greater than the index of the last element of the list, it is treated as if it is an index one greater than the last element. This allows \fBlreplace\fR to append elements to \fIlist\fR. -.VE TIP505 .PP If \fIlast\fR is less than \fIfirst\fR, then any specified elements will be inserted into the list before the element specified by \fIfirst\fR @@ -82,7 +80,6 @@ proc lremove {listVariable value} { } .CE .PP -.VS TIP505 Appending elements to the list; note that \fBend+2\fR will initially be treated as if it is \fB6\fR here, but both that and \fB12345\fR are greater than the index of the final item so they behave identically: @@ -93,7 +90,6 @@ a b c d e % set var [\fBlreplace\fR $var 12345 end+2 f g h i] a b c d e f g h i .CE -.VE TIP505 .SH "SEE ALSO" list(n), lappend(n), lassign(n), ledit(n), lindex(n), linsert(n), llength(n), lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), diff --git a/doc/tclvars.n b/doc/tclvars.n index 180e540..344050a 100644 --- a/doc/tclvars.n +++ b/doc/tclvars.n @@ -10,7 +10,7 @@ .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME -argc, argv, argv0, auto_path, env, errorCode, errorInfo, tcl_interactive, tcl_library, tcl_nonwordchars, tcl_patchLevel, tcl_pkgPath, tcl_platform, tcl_precision, tcl_rcFileName, tcl_traceCompile, tcl_traceExec, tcl_wordchars, tcl_version \- Variables used by Tcl +argc, argv, argv0, auto_path, env, errorCode, errorInfo, tcl_interactive, tcl_library, tcl_patchLevel, tcl_pkgPath, tcl_platform, tcl_precision, tcl_rcFileName, tcl_traceCompile, tcl_traceExec, tcl_version \- Variables used by Tcl .BE .SH DESCRIPTION .PP @@ -322,7 +322,6 @@ On UNIX machines, this is the value returned by \fBuname -s\fR. The version number for the operating system running on this machine. On UNIX machines, this is the value returned by \fBuname -r\fR. .IP \fBpathSeparator\fR -'\" Defined by TIP #315 The character that should be used to \fBsplit\fR PATH-like environment variables into their corresponding list of directory names. .IP \fBplatform\fR @@ -456,24 +455,6 @@ and interpreter. This variable and functionality only exist if \fBTCL_COMPILE_DEBUG\fR was defined during Tcl's compilation. .RE -.\" VARIABLE: tcl_wordchars -.TP -\fBtcl_wordchars\fR -. -The value of this variable is a regular expression that can be set to -control what are considered -.QW word -characters. It defaults to \fB\ew\fR, which is any Unicode -word character (number, letter, or underscore). -.\" VARIABLE: tcl_nonwordchars -.TP -\fBtcl_nonwordchars\fR -. -The value of this variable is a regular expression that can be set to -control what are considered -.QW non-word -characters. It defaults to \fB\eW\fR, which is anything but a -Unicode word character (number, letter, or underscore). .\" VARIABLE: tcl_version .TP \fBtcl_version\fR diff --git a/doc/tm.n b/doc/tm.n index 6bb1ac3..bfe79d4 100644 --- a/doc/tm.n +++ b/doc/tm.n @@ -307,9 +307,9 @@ fails because the user is unknown will be omitted from search paths. .SH "SEE ALSO" package(n), Tcl Improvement Proposal #189 .QW "\fITcl Modules\fR" -(online at https://tip.tcl-lang.org/189.html), Tcl Improvement Proposal #190 +(online at https://core.tcl-lang.org/tips/doc/trunk/tip/189.md), Tcl Improvement Proposal #190 .QW "\fIImplementation Choices for Tcl Modules\fR" -(online at https://tip.tcl-lang.org/190.html) +(online at https://core.tcl-lang.org/tips/doc/trunk/tip/190.md) .SH "KEYWORDS" modules, package .\" Local Variables: diff --git a/doc/zlib.n b/doc/zlib.n index 4c6cb2b..c8349d3 100644 --- a/doc/zlib.n +++ b/doc/zlib.n @@ -141,7 +141,6 @@ to the \fBzlib push\fR command: .\" OPTION: -dictionary .TP \fB\-dictionary\fI binData\fR -.VS "TIP 400" Sets the compression dictionary to use when working with compressing or decompressing the data to be \fIbinData\fR. Not valid for transformations that work with gzip-format data. The dictionary should consist of strings (byte @@ -149,7 +148,6 @@ sequences) that are likely to be encountered later in the data to be compressed, with the most commonly used strings preferably put towards the end of the dictionary. Tcl provides no mechanism for choosing a good such dictionary for a particular data sequence. -.VE .\" OPTION: -header .TP \fB\-header\fI dictionary\fR @@ -193,7 +191,6 @@ compression algorithm depends on what format is being produced or consumed. .\" OPTION: -dictionary .TP \fB\-dictionary\fI binData\fR -.VS "TIP 400" This read-write options gets or sets the initial compression dictionary to use when working with compressing or decompressing the data to be \fIbinData\fR. It is not valid for transformations that work with gzip-format data, and should @@ -201,7 +198,6 @@ not normally be set on compressing transformations other than at the point where the transformation is stacked. Note that this cannot be used to get the current active compression dictionary mid-stream, as that information is not exposed by the underlying library. -.VE .\" OPTION: -flush .TP \fB\-flush\fI type\fR @@ -243,7 +239,6 @@ and \fIoptions\fR are supported: The stream will be a compressing stream that produces zlib-format output, using compression level \fIlevel\fR (if specified) which will be an integer from 0 to 9, -.VS "TIP 400" and the compression dictionary \fIbindata\fR (if specified). .VE .TP @@ -251,7 +246,6 @@ and the compression dictionary \fIbindata\fR (if specified). . The stream will be a decompressing stream that takes zlib-format input and produces uncompressed output. -.VS "TIP 400" If \fIbindata\fR is supplied, it is a compression dictionary to use if required. .VE @@ -261,11 +255,9 @@ required. The stream will be a compressing stream that produces raw output, using compression level \fIlevel\fR (if specified) which will be an integer from 0 to 9, -.VS "TIP 400" and the compression dictionary \fIbindata\fR (if specified). Note that the raw compressed data includes no metadata about what compression dictionary was used, if any; that is a feature of the zlib-format data. -.VE .TP \fBzlib stream gunzip\fR . @@ -283,11 +275,9 @@ for keys see \fBzlib gzip\fR). . The stream will be a decompressing stream that takes raw compressed input and produces uncompressed output. -.VS "TIP 400" If \fIbindata\fR is supplied, it is a compression dictionary to use. Note that there are no checks in place to determine whether the compression dictionary is correct. -.VE .RE .SS "CHECKSUMMING SUBCOMMANDS" .\" METHOD: adler32 @@ -380,10 +370,8 @@ way in which the transformation is applied: .\" OPTION: -dictionary .TP \fB\-dictionary\fI binData\fR -.VS "TIP 400" Sets the compression dictionary to use when working with compressing or decompressing the data to be \fIbinData\fR. -.VE .\" OPTION: -finalize .TP \fB\-finalize\fR -- cgit v0.12 From 1d6ca919e2bd2dff2c646deab580b91da8ce1d74 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 18 Feb 2025 13:39:06 +0000 Subject: Be consistant in .VS/.VE tags in documentation: Just mention TIP number, nothing else. --- doc/Class.3 | 8 ++++---- doc/CrtChannel.3 | 8 ++++---- doc/LinkVar.3 | 36 ++++++++++++++++++------------------ doc/chan.n | 4 ++-- doc/coroutine.n | 24 ++++++++++++------------ doc/define.n | 4 ++-- doc/dict.n | 4 ++-- doc/encoding.n | 36 ++++++++++++++++++------------------ doc/expr.n | 12 ++++++------ doc/file.n | 12 ++++++------ doc/info.n | 16 ++++++++-------- doc/library.n | 16 ++++++++-------- doc/mathfunc.n | 32 ++++++++++++++++---------------- doc/mathop.n | 20 ++++++++++---------- doc/msgcat.n | 42 +++++++++++++++++++++--------------------- doc/open.n | 20 ++++++++++---------- doc/regsub.n | 8 ++++---- doc/string.n | 4 ++-- 18 files changed, 153 insertions(+), 153 deletions(-) diff --git a/doc/Class.3 b/doc/Class.3 index ed549c0..4a659c1 100644 --- a/doc/Class.3 +++ b/doc/Class.3 @@ -56,13 +56,13 @@ Tcl_ObjectMapMethodNameProc .sp \fBTcl_ObjectSetMethodNameMapper\fR(\fIobject\fR, \fImethodNameMapper\fR) .sp -.VS "TIP 605" +.VS TIP605 Tcl_Class \fBTcl_GetClassOfObject\fR(\fIobject\fR) .sp Tcl_Obj * \fBTcl_GetObjectClassName\fR(\fIinterp\fR, \fIobject\fR) -.VE "TIP 605" +.VE TIP605 .fi .SH ARGUMENTS .AS void *metadata in/out @@ -123,13 +123,13 @@ function. Note that the Tcl_Obj reference returned by \fBTcl_GetObjectName\fR is a shared reference. You can also get whether the object has been marked for deletion with \fBTcl_ObjectDeleted\fR (it returns true if deletion of the object has begun); this can be useful during the processing of methods. -.VS "TIP 605" +.VS TIP605 The class of an object can be retrieved with \fBTcl_GetClassOfObject\fR, and the name of the class of an object with \fBTcl_GetObjectClassName\fR; note that these two \fImay\fR return NULL during deletion of an object (this is transient, and only occurs when the object is a long way through being deleted). -.VE "TIP 605" +.VE TIP605 .PP Instances of classes are created using \fBTcl_NewObjectInstance\fR, which creates an object from any class (and which is internally called by both diff --git a/doc/CrtChannel.3 b/doc/CrtChannel.3 index 3c622f2..10a227f 100644 --- a/doc/CrtChannel.3 +++ b/doc/CrtChannel.3 @@ -35,10 +35,10 @@ Tcl_ThreadId int \fBTcl_GetChannelMode\fR(\fIchannel\fR) .sp -.VS 8.7 +.VS TIP220 int \fBTcl_RemoveChannelMode\fR(\fIinterp, channel, mode\fR) -.VE 8.7 +.VE TIP220 .sp int \fBTcl_GetChannelBufferSize\fR(\fIchannel\fR) @@ -239,7 +239,7 @@ events to the correct event queue even for a multi-threaded core. and \fBTCL_WRITABLE\fR, indicating whether the channel is open for input and output. .PP -.VS 8.7 +.VS TIP220 .PP \fBTcl_RemoveChannelMode\fR removes an access privilege from the channel, either \fBTCL_READABLE\fR or \fBTCL_WRITABLE\fR, and returns @@ -247,7 +247,7 @@ a regular Tcl result code, \fBTCL_OK\fR, or \fBTCL_ERROR\fR. The function throws an error if either an invalid mode is specified or the result of the removal would be an inaccessible channel. In that case an error message is left in the interp argument, if not NULL. -.VE 8.7 +.VE TIP220 .PP \fBTcl_GetChannelBufferSize\fR returns the size, in bytes, of buffers allocated to store input or output in \fIchannel\fR. If the value was not set diff --git a/doc/LinkVar.3 b/doc/LinkVar.3 index ffedb9d..0fe4122 100644 --- a/doc/LinkVar.3 +++ b/doc/LinkVar.3 @@ -17,10 +17,10 @@ Tcl_LinkArray, Tcl_LinkVar, Tcl_UnlinkVar, Tcl_UpdateLinkedVar \- link Tcl varia int \fBTcl_LinkVar\fR(\fIinterp, varName, addr, type\fR) .sp -.VS "TIP 312" +.VS TIP312 int \fBTcl_LinkArray\fR(\fIinterp, varName, addr, type, size\fR) -.VE "TIP 312" +.VE TIP312 .sp \fBTcl_UnlinkVar\fR(\fIinterp, varName\fR) .sp @@ -36,10 +36,10 @@ Name of global variable. .AP void *addr in Address of C variable that is to be linked to \fIvarName\fR. .sp -.VS "TIP 312" +.VS TIP312 In \fBTcl_LinkArray\fR, may be NULL to tell Tcl to create the storage for the array in the variable. -.VE "TIP 312" +.VE TIP312 .AP int type in Type of C variable for \fBTcl_LinkVar\fR or type of array element for \fBTcl_LinkArray\fR. Must be one of \fBTCL_LINK_INT\fR, @@ -52,18 +52,18 @@ Type of C variable for \fBTcl_LinkVar\fR or type of array element for In \fBTcl_LinkVar\fR, the additional linked type \fBTCL_LINK_STRING\fR may be used. .sp -.VS "TIP 312" +.VS TIP312 In \fBTcl_LinkArray\fR, the additional linked types \fBTCL_LINK_CHARS\fR and \fBTCL_LINK_BINARY\fR may be used. -.VE "TIP 312" +.VE TIP312 .sp All the above for both functions may be optionally OR'ed with \fBTCL_LINK_READ_ONLY\fR to make the Tcl variable read-only. .AP Tcl_Size size in -.VS "TIP 312" +.VS TIP312 The number of elements in the C array. Must be greater than zero. -.VE "TIP 312" +.VE TIP312 .BE .SH DESCRIPTION .PP @@ -78,12 +78,12 @@ while setting up the link (e.g. because \fIvarName\fR is the name of array) then \fBTCL_ERROR\fR is returned and the interpreter's result contains an error message. .PP -.VS "TIP 312" +.VS TIP312 \fBTcl_LinkArray\fR is similar, but for arrays of fixed size (given by the \fIsize\fR argument). When asked to allocate the backing C array storage (via the \fIaddr\fR argument being NULL), it writes the address that it allocated to the Tcl interpreter result. -.VE "TIP 312" +.VE TIP312 .PP The \fItype\fR argument specifies the type of the C variable, or the type of the elements of the C array, @@ -122,17 +122,17 @@ integer representations (like the empty string, '+', '-' or the hex/octal/decimal/binary prefix) are accepted as if they are valid too. .RS .PP -.VS "TIP 312" +.VS TIP312 If using an array of these, consider using \fBTCL_LINK_CHARS\fR instead. -.VE "TIP 312" +.VE TIP312 .RE .TP \fBTCL_LINK_CHARS\fR -.VS "TIP 312" +.VS TIP312 The C array is of type \fBchar *\fR and is mapped into Tcl as a string. Any value written into the Tcl variable must have the same length as the underlying storage. Only supported with \fBTcl_LinkArray\fR. -.VE "TIP 312" +.VE TIP312 .TP \fBTCL_LINK_UCHAR\fR . @@ -146,18 +146,18 @@ representations (like the empty string, '+', '-' or the hex/octal/decimal/binary prefix) are accepted as if they are valid too. .RS .PP -.VS "TIP 312" +.VS TIP312 If using an array of these, consider using \fBTCL_LINK_BINARY\fR instead. -.VE "TIP 312" +.VE TIP312 .RE .TP \fBTCL_LINK_BINARY\fR -.VS "TIP 312" +.VS TIP312 The C array is of type \fBunsigned char *\fR and is mapped into Tcl as a bytearray. Any value written into the Tcl variable must have the same length as the underlying storage. Only supported with \fBTcl_LinkArray\fR. -.VE "TIP 312" +.VE TIP312 .TP \fBTCL_LINK_SHORT\fR . diff --git a/doc/chan.n b/doc/chan.n index a130920..730c80a 100644 --- a/doc/chan.n +++ b/doc/chan.n @@ -198,7 +198,7 @@ Otherwise (the default) there is no special end of file character marker. The acceptable range for \fB\-eofchar\fR values is \ex01 - \ex7f; attempting to set \fB\-eofchar\fR to a value outside of this range will generate an error. -.VS "TCL8.7 TIP656" +.VS TIP656 .\" OPTION: -profile .TP \fB\-profile\fI profile\fR @@ -208,7 +208,7 @@ transforms in use for the channel's input and output will then be subject to the rules of that profile. Any failures will result in a channel error. See \fBPROFILES\fR in the \fBencoding(n)\fR documentation for details about encoding profiles. -.VE "TCL8.7 TIP656" +.VE TIP656 .\" OPTION: -translation .TP \fB\-translation\fI translation\fR diff --git a/doc/coroutine.n b/doc/coroutine.n index 6dae482..3a029d4 100644 --- a/doc/coroutine.n +++ b/doc/coroutine.n @@ -18,10 +18,10 @@ coroutine, yield, yieldto, coroinject, coroprobe \- Create and produce values fr \fByieldto\fI command\fR ?\fIarg...\fR? \fIname\fR ?\fIvalue...\fR? -.VS "8.7, TIP383" +.VS TIP383 \fBcoroinject \fIcoroName command\fR ?\fIarg...\fR? \fBcoroprobe \fIcoroName command\fR ?\fIarg...\fR? -.VE "8.7, TIP383" +.VE TIP383 .fi .BE .SH DESCRIPTION @@ -78,7 +78,7 @@ global namespace and there will be no stack frames above it (in the sense of \fBupvar\fR and \fBuplevel\fR). However, which command to call will be determined in the namespace that the \fBcoroutine\fR command was called from. .PP -.VS "8.7, TIP383" +.VS TIP383 A suspended coroutine (i.e., one that has \fByield\fRed or \fByieldto\fR-d) may have its state inspected (or modified) at that point by using \fBcoroprobe\fR to run a command at the point where the coroutine is at. The @@ -93,24 +93,24 @@ Similarly, the \fBcoroinject\fR command may be used to place a command to be run inside a suspended coroutine (when it is resumed) to process arguments, with quite a bit of similarity to \fBcoroprobe\fR. However, with \fBcoroinject\fR there are several key differences: -.VE "8.7, TIP383" +.VE TIP383 .IP \(bu -.VS "8.7, TIP383" +.VS TIP383 The coroutine is not immediately resumed after the injection has been done. A consequence of this is that multiple injections may be done before the coroutine is resumed. The injected commands are performed in \fIreverse order of definition\fR (that is, they are internally stored on a stack). -.VE "8.7, TIP383" +.VE TIP383 .IP \(bu -.VS "8.7, TIP383" +.VS TIP383 An additional two arguments are appended to the list of arguments to be run (that is, the \fIcommand\fR and its \fIargs\fR are extended by two elements). The first is the name of the command that suspended the coroutine (\fByield\fR or \fByieldto\fR), and the second is the argument (or list of arguments, in the case of \fByieldto\fR) that is the current resumption value. -.VE "8.7, TIP383" +.VE TIP383 .IP \(bu -.VS "8.7, TIP383" +.VS TIP383 The result of the injected command is used as the result of the \fByield\fR or \fByieldto\fR that caused the coroutine to become suspended. Where there are multiple injected commands, the result of one becomes the resumption value @@ -124,7 +124,7 @@ operations may only be applied to coroutines that are suspended. (If a coroutine is running then any introspection code would be merely inspecting the state of where it is currently running; \fBcoroinject\fR/\fBcoroprobe\fR are unnecessary in that case.) -.VE "8.7, TIP383" +.VE TIP383 .SH EXAMPLES .PP This example shows a coroutine that will produce an infinite sequence of @@ -207,7 +207,7 @@ proc juggler {name target {value ""}} { \fBcoroutine\fR j3 juggler Moe j1]] "Nyuck!Nyuck!Nyuck!" .CE .PP -.VS "8.7, TIP383" +.VS TIP383 This example shows a simple coroutine that collects non-empty values and returns a list of them when not given an argument. It also shows how we can look inside the coroutine to find out what it is doing, and how we can modify @@ -245,7 +245,7 @@ puts [\fBcoroprobe \fIcollect\fR set accumulator] puts [\fIcollect\fR] # ==> 123 {abc def} 456 pqr RST xyz .CE -.VE "8.7, TIP383" +.VE TIP383 .SS "DETAILED SEMANTICS" .PP This example demonstrates that coroutines start from the global namespace, and diff --git a/doc/define.n b/doc/define.n index 775cdc4..8146d59 100644 --- a/doc/define.n +++ b/doc/define.n @@ -156,7 +156,7 @@ be a namespace that is unique to the current object. The method will be exported if \fIname\fR starts with a lower-case letter, and non-exported otherwise; this behavior can be overridden via \fBexport\fR and \fBunexport\fR -.VS TIP519 +.VS TIP519 or by specifying \fB\-export\fR, \fB\-private\fR or \fB\-unexport\fR in the optional parameter \fIoption\fR. .VE TIP519 @@ -379,7 +379,7 @@ method will be \fIbodyScript\fR. When the body of the method is evaluated, the current namespace of the method will be a namespace that is unique to the object. The method will be exported if \fIname\fR starts with a lower-case letter, and non-exported otherwise; -.VS TIP519 +.VS TIP519 this can be overridden by specifying \fB\-export\fR, \fB\-private\fR or \fB\-unexport\fR in the optional parameter \fIoption\fR, or via the \fBexport\fR and \fBunexport\fR definitions. diff --git a/doc/dict.n b/doc/dict.n index 1517573..fdd020a 100644 --- a/doc/dict.n +++ b/doc/dict.n @@ -129,7 +129,7 @@ present in the dictionary. \fBdict getdef \fIdictionaryValue \fR?\fIkey ...\fR? \fIkey default\fR .TP \fBdict getwithdefault \fIdictionaryValue \fR?\fIkey ...\fR? \fIkey default\fR -.VS "8.7, TIP342" +.VS TIP342 This behaves the same as \fBdict get\fR (with at least one \fIkey\fR argument), returning the value that the key path maps to in the dictionary \fIdictionaryValue\fR, except that instead of producing an @@ -140,7 +140,7 @@ is absent, it returns the \fIdefault\fR argument instead. Note that there must always be at least one \fIkey\fR provided, and that \fBdict getdef\fR and \fBdict getwithdefault\fR are aliases for each other. .RE -.VE "8.7, TIP342" +.VE TIP342 .\" METHOD: incr .TP \fBdict incr \fIdictionaryVariable key \fR?\fIincrement\fR? diff --git a/doc/encoding.n b/doc/encoding.n index c28406f..43da934 100644 --- a/doc/encoding.n +++ b/doc/encoding.n @@ -30,16 +30,16 @@ Performs one of several encoding related operations, depending on .\" METHOD: convertfrom .TP \fBencoding convertfrom\fR ?\fIencoding\fR? \fIdata\fR -.VS "TCL8.7 TIP607, TIP656" +.VS "TIP607, TIP656" .TP \fBencoding convertfrom\fR ?\fB-profile \fIprofile\fR? ?\fB-failindex var\fR? \fIencoding data\fR -.VE "TCL8.7 TIP607, TIP656" +.VE "TIP607, TIP656" . Converts \fIdata\fR, which should be in binary string encoded as per \fIencoding\fR, to a Tcl string. If \fIencoding\fR is not specified, the current system encoding is used. .PP -.VS "TCL8.7 TIP607, TIP656" +.VS "TIP607, TIP656" The \fB-profile\fR option determines the command behavior in the presence of conversion errors. See the \fBPROFILES\fR section below for details. Any premature termination of processing due to errors is reported through an exception if @@ -51,7 +51,7 @@ error is returned as the result of the command. In addition, the index of the source byte triggering the error is stored in \fBvar\fR. If no errors are encountered, the entire result of the conversion is returned and the value \fB-1\fR is stored in \fBvar\fR. -.VE "TCL8.7 TIP607, TIP656" +.VE "TIP607, TIP656" .\" METHOD: convertto .TP \fBencoding convertto\fR ?\fIencoding\fR? \fIdata\fR @@ -63,10 +63,10 @@ string that contains the sequence of bytes representing the converted string in the specified encoding. If \fIencoding\fR is not specified, the current system encoding is used. .PP -.VS "TCL8.7 TIP607, TIP656" +.VS "TIP607, TIP656" The \fB-profile\fR and \fB-failindex\fR options have the same effect as described for the \fBencoding convertfrom\fR command. -.VE "TCL8.7 TIP607, TIP656" +.VE "TIP607, TIP656" .\" METHOD: dirs .TP \fBencoding dirs\fR ?\fIdirectoryList\fR? @@ -94,9 +94,9 @@ are guaranteed to be present in the list. .\" METHOD: profiles .TP \fBencoding profiles\fR -.VS "TCL8.7 TIP656" +.VS TIP656 Returns a list of the names of encoding profiles. See \fBPROFILES\fR below. -.VE "TCL8.7 TIP656" +.VE TIP656 .\" METHOD: system .TP \fBencoding system\fR ?\fIencoding\fR? @@ -107,30 +107,30 @@ system encoding is used whenever Tcl passes strings to system calls. .\" Do not put .VS on whole section as that messes up the bullet list alignment .SH PROFILES .PP -.VS "TCL8.7 TIP656" +.VS TIP656 Operations involving encoding transforms may encounter several types of errors such as invalid sequences in the source data, characters that cannot be encoded in the target encoding and so on. A \fIprofile\fR prescribes the strategy for dealing with such errors in one of two ways: -.VE "TCL8.7 TIP656" +.VE TIP656 . .IP \(bu -.VS "TCL8.7 TIP656" +.VS TIP656 Terminating further processing of the source data. The profile does not determine how this premature termination is conveyed to the caller. By default, this is signalled by raising an exception. If the \fB-failindex\fR option is specified, errors are reported through that mechanism. -.VE "TCL8.7 TIP656" +.VE TIP656 .IP \(bu -.VS "TCL8.7 TIP656" +.VS TIP656 Continue further processing of the source data using a fallback strategy such as replacing or discarding the offending bytes in a profile-defined manner. -.VE "TCL8.7 TIP656" +.VE TIP656 .PP The following profiles are currently implemented with \fBstrict\fR being the default if the \fB-profile\fR is not specified. -.VS "TCL8.7 TIP656" +.VS TIP656 .TP \fBstrict\fR . @@ -173,7 +173,7 @@ code points that cannot be represented in the target encoding are transformed to an encoding-specific fallback character, U+FFFD REPLACEMENT CHARACTER for UTF targets and generally `?` for other encodings. -.VE "TCL8.7 TIP656" +.VE TIP656 .SH EXAMPLES .PP These examples use the utility proc below that prints the Unicode code points @@ -195,7 +195,7 @@ U+00306F The result is the unicode codepoint .QW "\eu306F" , which is the Hiragana letter HA. -.VS "TCL8.7 TIP607, TIP656" +.VS "TIP607, TIP656" .PP Example 2: Error handling based on profiles: .PP @@ -232,7 +232,7 @@ A % set idx 1 .CE -.VE "TCL8.7 TIP607, TIP656" +.VE "TIP607, TIP656" .PP .SH "SEE ALSO" Tcl_GetEncoding(3), fconfigure(n) diff --git a/doc/expr.n b/doc/expr.n index a81c836..c626752 100644 --- a/doc/expr.n +++ b/doc/expr.n @@ -41,11 +41,11 @@ When the result of expression is an integer, it is in decimal form, and when the result is a floating-point number, it is in the form produced by the \fB%g\fR format specifier of \fBformat\fR. .PP -.VS "TIP 582" +.VS TIP582 At any point in the expression except within double quotes or braces, \fB#\fR is the beginning of a comment, which lasts to the end of the line or the end of the expression, whichever comes first. -.VE "TIP 582" +.VE TIP582 .SS OPERANDS .PP An expression consists of a combination of operands, operators, parentheses and @@ -198,12 +198,12 @@ comparison is done using UNICODE string comparison, as with the string comparison operators below, which have the same precedence. .TP 20 \fBlt\0\0gt\0\0le\0\0ge\fR -.VS "8.7, TIP461" +.VS TIP461 Boolean string comparisons: less than, greater than, less than or equal, and greater than or equal. These always compare values using their UNICODE strings (also see \fBstring compare\fR), unlike with the numeric-preferring comparisons above, which have the same precedence. -.VE "8.7, TIP461" +.VE TIP461 .TP 20 \fB==\0\0!=\fR . @@ -439,13 +439,13 @@ A string comparison whose result is 1: \fBexpr\fR {"0y" > "0x12"} .CE .PP -.VS "8.7, TIP461" +.VS TIP461 A forced string comparison whose result is 0: .PP .CS \fBexpr\fR {"0x03" gt "2"} .CE -.VE "8.7, TIP461" +.VE TIP461 .PP Define a procedure that computes an .QW interesting diff --git a/doc/file.n b/doc/file.n index 9312c10..3a41491 100644 --- a/doc/file.n +++ b/doc/file.n @@ -218,7 +218,7 @@ element of \fIname\fR then returns the empty string. .\" METHOD: home .TP \fBfile home ?\fIusername\fR? -.VS "8.7, TIP 602" +.VS TIP602 If no argument is specified, the command returns the home directory of the current user. This is generally the value of the \fB$HOME\fR environment variable except that on Windows platforms backslashes @@ -233,7 +233,7 @@ even when \fIusername\fR corresponds to the current user. An error is raised if the \fIusername\fR does not correspond to a user account on the system. .RE -.VE "8.7, TIP 602" +.VE TIP602 .\" METHOD: isdirectory .TP \fBfile isdirectory \fIname\fR @@ -500,7 +500,7 @@ return \fBb\fR. .\" METHOD: tempdir .TP \fBfile tempdir\fR ?\fItemplate\fR? -.VS "8.7, TIP 431" +.VS TIP431 Creates a temporary directory (guaranteed to be newly created and writable by the current script) and returns its name. If \fItemplate\fR is given, it specifies one of or both of the existing directory (on a filesystem controlled @@ -527,7 +527,7 @@ between platforms: /var/tmp/myapp_0ihS0n .CE .RE -.VE "8.7, TIP 431" +.VE TIP431 .\" METHOD: tempfile .TP \fBfile tempfile\fR ?\fInameVar\fR? ?\fItemplate\fR? @@ -548,7 +548,7 @@ native APIs and external programs that require a filename. .\" METHOD: tildeexpand .TP \fBfile tildeexpand \fIname\fR -.VS "8.7, TIP 602" +.VS TIP602 Returns the result of performing tilde substitution on \fIname\fR. If the name begins with a tilde, then the file name will be interpreted as if the first element is replaced with the location of the home directory for the given user. @@ -561,7 +561,7 @@ retrieve the user's home directory for substitution. An error is raised if the .PP If the file name does not begin with a tilde, it is returned unmodified. .RE -.VE "8.7, TIP 602" +.VE TIP602 .\" METHOD: type .TP \fBfile type \fIname\fR diff --git a/doc/info.n b/doc/info.n index 592de63..13366d4 100644 --- a/doc/info.n +++ b/doc/info.n @@ -94,18 +94,18 @@ to allow users to type in commands that span multiple lines. .\" METHOD: constant .TP \fBinfo constant \fIvarName\fR -.VS "TIP 677" +.VS TIP677 Returns 1 if \fIvarName\fR is a constant variable (see \fBconst\fR) and 0 otherwise. -.VE "TIP 677" +.VE TIP677 .\" METHOD: consts .TP \fBinfo consts\fR ?\fIpattern\fR? -.VS "TIP 677" +.VS TIP677 Returns the list of constant variables (see \fBconst\fR) in the current scope, or the list of constant variables matching \fIpattern\fR (if that is provided) in a manner similar to \fBinfo vars\fR. -.VE "TIP 677" +.VE TIP677 .\" METHOD: coroutine .TP \fBinfo coroutine\fR @@ -529,7 +529,7 @@ class named \fIclass\fR. .\" METHOD: properties .TP \fBinfo class properties\fI class\fR ?\fIoptions...\fR -.VS "TIP 558" +.VS TIP558 This subcommand returns a sorted list of properties defined on the class named \fIclass\fR. The \fIoptions\fR define exactly which properties are returned: .RS @@ -552,7 +552,7 @@ returned. Only readable or writable properties are returned, not both. This option asks for the writable properties to be returned. Only readable or writable properties are returned, not both. .RE -.VE "TIP 558" +.VE TIP558 .\" METHOD: subclasses .TP \fBinfo class subclasses\fI class\fR ?\fIpattern\fR? @@ -762,7 +762,7 @@ This subcommand returns the name of the internal namespace of the object named .\" METHOD: properties .TP \fBinfo object properties\fI object\fR ?\fIoptions...\fR -.VS "TIP 558" +.VS TIP558 This subcommand returns a sorted list of properties defined on the object named \fIobject\fR. The \fIoptions\fR define exactly which properties are returned: @@ -786,7 +786,7 @@ returned. Only readable or writable properties are returned, not both. This option asks for the writable properties to be returned. Only readable or writable properties are returned, not both. .RE -.VE "TIP 558" +.VE TIP558 .\" METHOD: variables .TP \fBinfo object variables\fI object\fR ?\fB\-private\fR? diff --git a/doc/library.n b/doc/library.n index 0bad31a..5336e13 100644 --- a/doc/library.n +++ b/doc/library.n @@ -25,11 +25,11 @@ auto_execok, auto_import, auto_load, auto_mkindex, auto_qualify, auto_reset, for \fBtcl_startOfPreviousWord \fIstr start\fR \fBtcl_wordBreakAfter \fIstr start\fR \fBtcl_wordBreakBefore \fIstr start\fR -.VS "Tcl 8.7, TIP 670" +.VS TIP670 \fBforeachLine \fIfilename varName body\fR \fBreadFile \fIfilename\fR ?\fBtext\fR|\fBbinary\fR? \fBwriteFile \fIfilename\fR ?\fBtext\fR|\fBbinary\fR? \fIcontents\fR -.VE "Tcl 8.7, TIP 670" +.VE TIP670 .fi .BE .SH INTRODUCTION @@ -329,7 +329,7 @@ boundary. .\" COMMAND: foreachLine .TP \fBforeachLine \fIvarName filename body\fR -.VS "Tcl 8.7, TIP 670" +.VS TIP670 This reads in the text file named \fIfilename\fR one line at a time (using system defaults for reading text files). It writes that line to the variable named by \fIvarName\fR and then executes \fIbody\fR for that line. @@ -340,22 +340,22 @@ respectively. The overall result of \fBforeachLine\fR is the empty string (assuming no errors from I/O or from evaluating the body of the loop); the file will be closed prior to the procedure returning. -.VE "Tcl 8.7, TIP 670" +.VE TIP670 .\" COMMAND: readFile .TP \fBreadFile \fIfilename\fR ?\fBtext\fR|\fBbinary\fR? -.VS "Tcl 8.7, TIP 670" +.VS TIP670 Reads in the file named in \fIfilename\fR and returns its contents. The second argument says how to read in the file, either as \fBtext\fR (using the system defaults for reading text files) or as \fBbinary\fR (as uninterpreted bytes). The default is \fBtext\fR. When read as text, this will include any trailing newline. The file will be closed prior to the procedure returning. -.VE "Tcl 8.7, TIP 670" +.VE TIP670 .\" COMMAND: writeFile .TP \fBwriteFile \fIfilename\fR ?\fBtext\fR|\fBbinary\fR? \fIcontents\fR -.VS "Tcl 8.7, TIP 670" +.VS TIP670 Writes the \fIcontents\fR to the file named in \fIfilename\fR. The optional second argument says how to write to the file, either as \fBtext\fR (using the system defaults for writing text files) or as @@ -363,7 +363,7 @@ The optional second argument says how to write to the file, either as If a trailing newline is required, it will need to be provided in \fIcontents\fR. The result of this command is the empty string; the file will be closed prior to the procedure returning. -.VE "Tcl 8.7, TIP 670" +.VE TIP670 .SH "VARIABLES" .PP The following global variables are defined or used by the procedures in diff --git a/doc/mathfunc.n b/doc/mathfunc.n index c84dbf7..f0d296d 100644 --- a/doc/mathfunc.n +++ b/doc/mathfunc.n @@ -32,17 +32,17 @@ package require \fBTcl 8.5-\fR \fB::tcl::mathfunc::fmod\fI x y\fR \fB::tcl::mathfunc::hypot\fI x y\fR \fB::tcl::mathfunc::int\fI arg\fR -.VS "8.7, TIP 521" +.VS TIP521 \fB::tcl::mathfunc::isfinite\fI arg\fR \fB::tcl::mathfunc::isinf\fI arg\fR \fB::tcl::mathfunc::isnan\fI arg\fR \fB::tcl::mathfunc::isnormal\fI arg\fR -.VE "8.7, TIP 521" +.VE TIP521 \fB::tcl::mathfunc::isqrt\fI arg\fR -.VS "8.7, TIP 521" +.VS TIP521 \fB::tcl::mathfunc::issubnormal\fI arg\fR \fB::tcl::mathfunc::isunordered\fI x y\fR -.VE "8.7, TIP 521" +.VE TIP521 \fB::tcl::mathfunc::log\fI arg\fR \fB::tcl::mathfunc::log10\fI arg\fR \fB::tcl::mathfunc::max\fI arg\fR ?\fIarg\fR ...? @@ -207,35 +207,35 @@ element of the \fBtcl_platform\fR array. .\" COMMAND: isfinite .TP \fBisfinite \fIarg\fR -.VS "8.7, TIP 521" +.VS TIP521 Returns 1 if the floating-point number \fIarg\fR is finite. That is, if it is zero, subnormal, or normal. Returns 0 if the number is infinite or NaN. Throws an error if \fIarg\fR cannot be promoted to a floating-point value. -.VE "8.7, TIP 521" +.VE TIP521 .\" COMMAND: isinf .TP \fBisinf \fIarg\fR -.VS "8.7, TIP 521" +.VS TIP521 Returns 1 if the floating-point number \fIarg\fR is infinite. Returns 0 if the number is finite or NaN. Throws an error if \fIarg\fR cannot be promoted to a floating-point value. -.VE "8.7, TIP 521" +.VE TIP521 .\" COMMAND: isnan .TP \fBisnan \fIarg\fR -.VS "8.7, TIP 521" +.VS TIP521 Returns 1 if the floating-point number \fIarg\fR is Not-a-Number. Returns 0 if the number is finite or infinite. Throws an error if \fIarg\fR cannot be promoted to a floating-point value. -.VE "8.7, TIP 521" +.VE TIP521 .\" COMMAND: isnormal .TP \fBisnormal \fIarg\fR -.VS "8.7, TIP 521" +.VS TIP521 Returns 1 if the floating-point number \fIarg\fR is normal. Returns 0 if the number is zero, subnormal, infinite or NaN. Throws an error if \fIarg\fR cannot be promoted to a floating-point value. -.VE "8.7, TIP 521" +.VE TIP521 .\" COMMAND: isqrt .TP \fBisqrt \fIarg\fR @@ -247,22 +247,22 @@ number, \fIisqrt\fR will return a result of arbitrary precision. .\" COMMAND: issubnormal .TP \fBissubnormal \fIarg\fR -.VS "8.7, TIP 521" +.VS TIP521 Returns 1 if the floating-point number \fIarg\fR is subnormal, i.e., the result of gradual underflow. Returns 0 if the number is zero, normal, infinite or NaN. Throws an error if \fIarg\fR cannot be promoted to a floating-point value. -.VE "8.7, TIP 521" +.VE TIP521 .\" COMMAND: isunordered .TP \fBisunordered \fIx y\fR -.VS "8.7, TIP 521" +.VS TIP521 Returns 1 if \fIx\fR and \fIy\fR cannot be compared for ordering, that is, if either one is NaN. Returns 0 if both values can be ordered, that is, if they are both chosen from among the set of zero, subnormal, normal and infinite values. Throws an error if either \fIx\fR or \fIy\fR cannot be promoted to a floating-point value. -.VE "8.7, TIP 521" +.VE TIP521 .\" COMMAND: log .TP \fBlog \fIarg\fR diff --git a/doc/mathop.n b/doc/mathop.n index 95a5d0e..38b862b 100644 --- a/doc/mathop.n +++ b/doc/mathop.n @@ -35,12 +35,12 @@ package require \fBTcl 8.5-\fR \fB::tcl::mathop::>\fR ?\fIarg\fR ...? \fB::tcl::mathop::eq\fR ?\fIarg\fR ...? \fB::tcl::mathop::ne\fI arg arg\fR -.VS "8.7, TIP461" +.VS TIP461 \fB::tcl::mathop::lt\fR ?\fIarg\fR ...? \fB::tcl::mathop::le\fR ?\fIarg\fR ...? \fB::tcl::mathop::gt\fR ?\fIarg\fR ...? \fB::tcl::mathop::ge\fR ?\fIarg\fR ...? -.VE "8.7, TIP461" +.VE TIP461 \fB::tcl::mathop::in\fI arg list\fR \fB::tcl::mathop::ni\fI arg list\fR .fi @@ -228,39 +228,39 @@ operator or the \fBstring compare\fR command should be used instead. .\" COMMAND: lt .TP \fBlt\fR ?\fIarg\fR ...? -.VS "8.7, TIP461" +.VS TIP461 Returns whether the arbitrarily-many arguments are ordered, with each argument after the first having to be strictly more than the one preceding it. Comparisons are performed using UNICODE string comparison. If fewer than two arguments are present, this operation always returns a true value. -.VE "8.7, TIP461" +.VE TIP461 .\" COMMAND: le .TP \fBle\fR ?\fIarg\fR ...? -.VS "8.7, TIP461" +.VS TIP461 Returns whether the arbitrarily-many arguments are ordered, with each argument after the first having to be equal to or strictly more than the one preceding it. Comparisons are performed using UNICODE string comparison. If fewer than two arguments are present, this operation always returns a true value. -.VE "8.7, TIP461" +.VE TIP461 .\" COMMAND: gt .TP \fBgt\fR ?\fIarg\fR ...? -.VS "8.7, TIP461" +.VS TIP461 Returns whether the arbitrarily-many arguments are ordered, with each argument after the first having to be strictly less than the one preceding it. Comparisons are performed using UNICODE string comparison. If fewer than two arguments are present, this operation always returns a true value. -.VE "8.7, TIP461" +.VE TIP461 .\" COMMAND: ge .TP \fBge\fR ?\fIarg\fR ...? -.VS "8.7, TIP461" +.VS TIP461 Returns whether the arbitrarily-many arguments are ordered, with each argument after the first having to be equal to or strictly less than the one preceding it. Comparisons are performed using UNICODE string comparison. If fewer than two arguments are present, this operation always returns a true value. -.VE "8.7, TIP461" +.VE TIP461 .SS "BIT-WISE OPERATORS" .PP The behaviors of the bit-wise operator commands (all of which only operate on diff --git a/doc/msgcat.n b/doc/msgcat.n index 4c844e2..94884f3 100644 --- a/doc/msgcat.n +++ b/doc/msgcat.n @@ -18,13 +18,13 @@ msgcat \- Tcl message catalog \fB::msgcat::mc \fIsrc-string\fR ?\fIarg arg ...\fR? \fB::msgcat::mcmax ?\fIsrc-string src-string ...\fR? \fB::msgcat::mcexists\fR ?\fB\-exactnamespace\fR? ?\fB\-exactlocale\fR? \fIsrc-string\fR -.VS "TIP 490" +.VS TIP490 \fB::msgcat::mcpackagenamespaceget\fR -.VE "TIP 490" +.VE TIP490 \fB::msgcat::mclocale \fR?\fInewLocale\fR? -.VS "TIP 499" +.VS TIP499 \fB::msgcat::mcpreferences\fR ?\fIlocale preference\fR? ... -.VE "TIP 499" +.VE TIP499 \fB::msgcat::mcloadedlocales subcommand\fR \fB::msgcat::mcload \fIdirname\fR \fB::msgcat::mcset \fIlocale src-string \fR?\fItranslate-string\fR? @@ -35,9 +35,9 @@ msgcat \- Tcl message catalog \fB::msgcat::mcpackagelocale subcommand\fR ?\fIlocale\fR? \fB::msgcat::mcpackageconfig subcommand\fI option\fR ?\fIvalue\fR? \fB::msgcat::mcforgetpackage\fR -.VS "TIP 499" +.VS TIP499 \fB::msgcat::mcutil subcommand\fR ?\fIlocale\fR? -.VS "TIP 499" +.VS TIP499 .fi .BE .SH DESCRIPTION @@ -63,9 +63,9 @@ decide to use the global locale or to use a package specific locale. The global locale may be changed on demand, for example by a user initiated language change or within a multi user application like a web server. .PP -.VS tip490 +.VS TIP490 Object oriented programming is supported by the use of a package namespace. -.VE tip490 +.VE TIP490 .PP .SH COMMANDS .\" COMMAND: mc @@ -95,7 +95,7 @@ later simply by defining new message catalog entries. .\" COMMAND: mcn .TP \fB::msgcat::mcn \fInamespace src-string\fR ?\fIarg arg ...\fR? -.VS "TIP 490" +.VS TIP490 Like \fB::msgcat::mc\fR, but with the message namespace specified as first argument. .PP @@ -126,16 +126,16 @@ It may also be limited by the option \fB\-exactlocale\fR to only check the first prefered locale (e.g. first element returned by \fB::msgcat::mcpreferences\fR if global locale is used). .PP -.VS "TIP 490" +.VS TIP490 An explicit package namespace may be specified by the option \fB\-namespace\fR. The namespace of the caller is used if not explicitly specified. .RE .PP -.VE "TIP 490" +.VE TIP490 .\" COMMAND: mcpackagenamespaceget .TP \fB::msgcat::mcpackagenamespaceget\fR -.VS "TIP 490" +.VS TIP490 Return the package namespace of the caller. This command handles all cases described in section \fBOBJECT ORIENTED PROGRAMMING\fR. .PP @@ -158,7 +158,7 @@ proc ::tooltip::show {widget messagenamespace message} { .CE .RE .PP -.VE "TIP 490" +.VE TIP490 .\" COMMAND: mclocale .TP \fB::msgcat::mclocale \fR?\fInewLocale\fR? @@ -195,7 +195,7 @@ Without arguments, returns an ordered list of the locales preferred by the user. The list is ordered from most specific to least preference. .PP -.VS "TIP 499" +.VS TIP499 .RS A set of locale preferences may be given to set the list of locale preferences. The current locale is also set, which is the first element of the locale @@ -213,7 +213,7 @@ configured by: .\" COMMAND: mcloadedlocales .TP \fB::msgcat::mcloadedlocales subcommand\fR -.VS "TIP 499" +.VS TIP499 This group of commands manage the list of loaded locales for packages not setting a package locale. .PP @@ -313,7 +313,7 @@ including all settings and translations. .PP .\" COMMAND: mcutil .\" METHOD: getpreferences -.VS "TIP 499" +.VS TIP499 .TP \fB::msgcat::mcutil getpreferences\fI locale\fR . @@ -331,7 +331,7 @@ fr_ch fr de_ch de {} . The system locale is returned as described by the section \fBLOCALE SPECIFICATION\fR. -.VE "TIP 499" +.VE TIP499 .PP .SH "LOCALE SPECIFICATION" .PP @@ -577,13 +577,13 @@ The package locale state (set or not) is not changed (in contrast to the command \fB::msgcat::mcpackagelocale set\fR). .PP .RS -.VS "TIP 499" +.VS TIP499 If a set of locale preferences is given, it is set as package locale preference list. The package locale is set to the first element of the preference list. A package locale is activated, if it was not set so far. .PP Locale preferences are loaded now for the package, if not yet loaded. -.VE "TIP 499" +.VE TIP499 .RE .PP .\" METHOD: loaded @@ -726,7 +726,7 @@ interpreter is invoked after command completion. Only exception is the callback \fBunknowncmd\fR, where an error causes the invoking \fBmc\fR-command to fail with that error. .PP -.VS tip490 +.VS TIP490 .SH "OBJECT ORIENTED PROGRAMMING" \fBmsgcat\fR supports packages implemented by object oriented programming. Objects and classes should be defined within a package namespace. @@ -776,7 +776,7 @@ namespace eval ::N4 { } .CE .PP -.VE tip490 +.VE TIP490 .SH EXAMPLES Packages which display a GUI may update their widgets when the global locale changes. To register to a callback, use: diff --git a/doc/open.n b/doc/open.n index 03a58e6..1b6ef9d 100644 --- a/doc/open.n +++ b/doc/open.n @@ -96,7 +96,7 @@ If a new file is created as part of opening it, \fIpermissions\fR conjunction with the process's file mode creation mask. \fIPermissions\fR defaults to 0666. .PP -.VS "8.7, TIP 603" +.VS TIP603 When the file opened is an ordinary disk file, the \fBchan configure\fR and \fBfconfigure\fR commands can be used to query this additional configuration option: @@ -117,7 +117,7 @@ on all platforms; other keys may be present too. POSIX platforms, and to a call to \fBGetFileInformationByHandle()\fR on Windows; the information reported is what those system calls produce. .RE -.VE "8.7, TIP 603" +.VE TIP603 .SH "COMMAND PIPELINES" .PP If the first character of \fIfileName\fR is @@ -249,7 +249,7 @@ XON and XOFF characters. .\" OPTION: -closemode .TP \fB\-closemode\fI closeMode\fR -.VS "8.7, TIP 160" +.VS TIP160 (Windows and Unix). This option is used to query or change the close mode of the serial channel, which defines how pending output in operating system buffers is handled when the channel is closed. The following values for @@ -266,11 +266,11 @@ interact unexpectedly with handling of \fBstderr\fR. indicates that Tcl should wait when closing the channel until all output has been consumed. This may slow down \fBclose\fR noticeably. .RE -.VE "8.7, TIP 160" +.VE TIP160 .\" OPTION: -inputmode .TP \fB\-inputmode\fI inputMode\fR -.VS "8.7, TIP 160" +.VS TIP160 (Unix only; Windows has the equivalent option on console channels). This option is used to query or change the input mode of the serial channel under the assumption that it is talking to a terminal, which controls how interactive @@ -303,7 +303,7 @@ turn on an automatic reset of the terminal when the channel is closed. (Unix only; Windows has the equivalent option on console channels). This option is query only. It retrieves a two-element list with the the current width and height of the terminal. -.VE "8.7, TIP 160" +.VE TIP160 .\" OPTION: -pollinterval .TP \fB\-pollinterval\fI msec\fR @@ -462,7 +462,7 @@ See the \fBPORTABILITY ISSUES\fR section of the \fBexec\fR command for additional information not specific to command pipelines about executing applications on the various platforms .SH "CONSOLE CHANNELS" -.VS "8.7, TIP 160" +.VS TIP160 On Windows only, console channels (usually \fBstdin\fR or \fBstdout\fR) support the following options: .\" OPTION: -inputmode @@ -504,7 +504,7 @@ console that this channel is talking to. .PP Note that the equivalent options exist on Unix, but are on the serial channel type. -.VE "8.7, TIP 160" +.VE TIP160 .SH "EXAMPLES" Open a file for writing, forcing it to be created and raising an error if it already exists. @@ -542,7 +542,7 @@ set binData [read $fl] close $fl .CE .PP -.VS "8.7, TIP 160" +.VS TIP160 Read a password securely from the user (assuming that the script is being run interactively): .PP @@ -556,7 +556,7 @@ try { chan configure stdin \fB-inputmode reset\fR } .CE -.VE "8.7, TIP 160" +.VE TIP160 .SH "SEE ALSO" file(n), close(n), filename(n), fconfigure(n), gets(n), read(n), puts(n), exec(n), pid(n), fopen(3) diff --git a/doc/regsub.n b/doc/regsub.n index cb8c2d4..cb41700 100644 --- a/doc/regsub.n +++ b/doc/regsub.n @@ -71,7 +71,7 @@ from the corresponding match. .\" OPTION: -command .TP \fB\-command\fR -.VS 8.7 +.VS TIP463 Changes the handling of \fIsubSpec\fR so that it is not treated as a template for a substitution string and the substrings .QW & @@ -95,7 +95,7 @@ The exact location indices that matched are not made available to the script. .PP See \fBEXAMPLES\fR below for illustrative cases. .RE -.VE 8.7 +.VE TIP463 .\" OPTION: -expanded .TP \fB\-expanded\fR @@ -220,7 +220,7 @@ set quoted [subst [string map {\en {\e\eu000a}} \e [\fBregsub\fR -all $RE $string $substitution]]] .CE .PP -.VS 8.7 +.VS TIP463 The above operation can be done using \fBregsub \-command\fR instead, which is often faster. (A full pre-computed \fBstring map\fR would be faster still, but the cost of computing the map for a transformation as complex as this can be @@ -274,7 +274,7 @@ set message "the quIck broWn fOX JUmped oVer the laZy dogS..." puts [\fBregsub\fR -all -command {\ew+} $message {string totitle}] # \(-> \fIThe Quick Brown Fox Jumped Over The Lazy Dogs..\fR .CE -.VE 8.7 +.VE TIP463 .SH "SEE ALSO" regexp(n), re_syntax(n), subst(n), string(n) .SH KEYWORDS diff --git a/doc/string.n b/doc/string.n index 480f3ce..a78a842 100644 --- a/doc/string.n +++ b/doc/string.n @@ -95,7 +95,7 @@ length of the string then this command returns an empty string. .\" METHOD: insert .TP \fBstring insert \fIstring index insertString\fR -.VS "TIP 504" +.VS TIP504 Returns a copy of \fIstring\fR with \fIinsertString\fR inserted at the \fIindex\fR'th character. The \fIindex\fR may be specified as described in the \fBSTRING INDICES\fR section. @@ -110,7 +110,7 @@ If \fIindex\fR is at or before the start of \fIstring\fR (e.g., \fIindex\fR is or after the end of \fIstring\fR (e.g., \fIindex\fR is \fBend\fR), \fIinsertString\fR is appended to \fIstring\fR. .RE -.VE "TIP 504" +.VE TIP504 .\" METHOD: is .TP \fBstring is \fIclass\fR ?\fB\-strict\fR? ?\fB\-failindex \fIvarname\fR? \fIstring\fR -- cgit v0.12 From 7e97ffc51b0d659b075bafa6c361613b35e7aab3 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 19 Feb 2025 08:29:41 +0000 Subject: Split off "9.0" branch, as preparation for TIP #711 --- README.md | 10 +++++----- win/rules.vc | 2 +- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/README.md b/README.md index 0a2e307..c6ffd6f 100644 --- a/README.md +++ b/README.md @@ -5,15 +5,15 @@ This is the **Tcl 9.0.2** source distribution. You can get any source release of Tcl from [our distribution site](https://sourceforge.net/projects/tcl/files/Tcl/). -9.0 (production release, daily build) +9.1 (in development, daily build) [![Build Status](https://github.com/tcltk/tcl/actions/workflows/linux-build.yml/badge.svg?branch=main)](https://github.com/tcltk/tcl/actions/workflows/linux-build.yml?query=branch%3Amain) [![Build Status](https://github.com/tcltk/tcl/actions/workflows/win-build.yml/badge.svg?branch=main)](https://github.com/tcltk/tcl/actions/workflows/win-build.yml?query=branch%3Amain) [![Build Status](https://github.com/tcltk/tcl/actions/workflows/mac-build.yml/badge.svg?branch=main)](https://github.com/tcltk/tcl/actions/workflows/mac-build.yml?query=branch%3Amain)
-8.7 (in development, daily build) -[![Build Status](https://github.com/tcltk/tcl/actions/workflows/linux-build.yml/badge.svg?branch=core-8-branch)](https://github.com/tcltk/tcl/actions/workflows/linux-build.yml?query=branch%3Acore-8-branch) -[![Build Status](https://github.com/tcltk/tcl/actions/workflows/win-build.yml/badge.svg?branch=core-8-branch)](https://github.com/tcltk/tcl/actions/workflows/win-build.yml?query=branch%3Acore-8-branch) -[![Build Status](https://github.com/tcltk/tcl/actions/workflows/mac-build.yml/badge.svg?branch=core-8-branch)](https://github.com/tcltk/tcl/actions/workflows/mac-build.yml?query=branch%3Acore-8-branch) +9.0 (production release, daily build) +[![Build Status](https://github.com/tcltk/tcl/actions/workflows/linux-build.yml/badge.svg?branch=core-9-0-branch)](https://github.com/tcltk/tcl/actions/workflows/linux-build.yml?query=branch%3Acore-9-0-branch) +[![Build Status](https://github.com/tcltk/tcl/actions/workflows/win-build.yml/badge.svg?branch=core-9-0-branch)](https://github.com/tcltk/tcl/actions/workflows/win-build.yml?query=branch%3Acore-9-0-branch) +[![Build Status](https://github.com/tcltk/tcl/actions/workflows/mac-build.yml/badge.svg?branch=core-9-0-branch)](https://github.com/tcltk/tcl/actions/workflows/mac-build.yml?query=branch%3Acore-9-0-branch) ## Contents 1. [Introduction](#intro) diff --git a/win/rules.vc b/win/rules.vc index 57bc770..170481f 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -697,7 +697,7 @@ LINKERFLAGS = $(LINKERFLAGS) -ltcg && [nmakehlp -V "$(_TCL_H)" "define TCL_MAJOR_VERSION" >> versions.vc] !endif !if [echo TCL_MINOR_VERSION = \>> versions.vc] \ - && [nmakehlp -V "$(_TCL_H)" TCL_MINOR_VERSION >> versions.vc] + && [nmakehlp -V "$(_TCL_H)" "define TCL_MINOR_VERSION" >> versions.vc] !endif !if [echo TCL_RELEASE_SERIAL = \>> versions.vc] \ && [nmakehlp -V "$(_TCL_H)" TCL_RELEASE_SERIAL >> versions.vc] -- cgit v0.12 From 4df16d173b7db56ca5ff6e0e8285a26018844fc1 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 20 Feb 2025 10:56:40 +0000 Subject: Apparently, create-dmg/create-dmg doesn't work yet on Apple silicon --- .github/workflows/onefiledist.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/onefiledist.yml b/.github/workflows/onefiledist.yml index f647a30..b962642 100644 --- a/.github/workflows/onefiledist.yml +++ b/.github/workflows/onefiledist.yml @@ -54,7 +54,7 @@ jobs: url: ${{ steps.upload.outputs.artifact-url }} macos: name: macOS - runs-on: macos-15 + runs-on: macos-14 defaults: run: shell: bash -- cgit v0.12 From 00c1e6ee3aa900b575f929135320a2e7d70d3aa0 Mon Sep 17 00:00:00 2001 From: bch Date: Fri, 21 Feb 2025 00:46:13 +0000 Subject: * In-code comments reflect what is actually happening - eg: Tcl_GetRange() does *not* only convert the Obj values to a valid Unicode string, it will preserve a byte-array if a byte-array is what is passed in. * s/bytearray/byte-array/, consistent with (eg) Tcl_NewByteArrayObj(3) * update Tcl_GetRange(3) doc to reflect the byte-array -preserving aspect. --- doc/StringObj.3 | 13 +++++----- generic/tclStringObj.c | 64 +++++++++++++++++++++++++++----------------------- 2 files changed, 41 insertions(+), 36 deletions(-) diff --git a/doc/StringObj.3 b/doc/StringObj.3 index 92775f7..df2bcf5 100644 --- a/doc/StringObj.3 +++ b/doc/StringObj.3 @@ -213,12 +213,13 @@ value's Unicode representation. If the index is out of range it returns -1; .PP \fBTcl_GetRange\fR returns a newly created value comprised of the -characters between \fIfirst\fR and \fIlast\fR (inclusive) in the value's -Unicode representation. If the value's Unicode representation -is invalid, the Unicode representation is regenerated from the value's -string representation. If \fIfirst\fR is negative, then the returned -string starts at the beginning of the value. If \fIlast\fR is negative, -then the returned string ends at the end of the value. +characters between \fIfirst\fR and \fIlast\fR (inclusive) in the +value's Unicode or byte-array representation. If the value is not +a byte-array and the values Unicode representation is invalid, the +Unicode representation is regenerated from the value's string +representation. If \fIfirst\fR is negative, then the returned +string starts at the beginning of the value. If \fIlast\fR is +negative, then the returned string ends at the end of the value. .PP \fBTcl_GetCharLength\fR returns the number of characters (as opposed to bytes) in the string value. diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index b3e6dec..987ab76 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -388,14 +388,14 @@ Tcl_GetCharLength( } /* - * Optimize the case where we're really dealing with a bytearray object; + * Optimize the case where we're really dealing with a byte-array object; * we don't need to convert to a string to perform the get-length operation. * - * Starting in Tcl 8.7, we check for a "pure" bytearray, because the - * machinery behind that test is using a proper bytearray ObjType. We - * could also compute length of an improper bytearray without shimmering - * but there's no value in that. We *want* to shimmer an improper bytearray - * because improper bytearrays have worthless internal reps. + * Starting in Tcl 8.7, we check for a "pure" byte-array, because the + * machinery behind that test is using a proper byte-array ObjType. We + * could also compute length of an improper byte-array without shimmering + * but there's no value in that. We *want* to shimmer an improper byte-array + * because improper byte-arrays have worthless internal reps. */ if (TclIsPureByteArray(objPtr)) { @@ -439,14 +439,14 @@ TclGetCharLength( } /* - * Optimize the case where we're really dealing with a bytearray object; + * Optimize the case where we're really dealing with a byte-array object; * we don't need to convert to a string to perform the get-length operation. * - * Starting in Tcl 8.7, we check for a "pure" bytearray, because the - * machinery behind that test is using a proper bytearray ObjType. We - * could also compute length of an improper bytearray without shimmering - * but there's no value in that. We *want* to shimmer an improper bytearray - * because improper bytearrays have worthless internal reps. + * Starting in Tcl 8.7, we check for a "pure" byte-array, because the + * machinery behind that test is using a proper byte-array ObjType. We + * could also compute length of an improper byte-array without shimmering + * but there's no value in that. We *want* to shimmer an improper byte-array + * because improper byte-arrays have worthless internal reps. */ if (TclIsPureByteArray(objPtr)) { @@ -700,14 +700,16 @@ Tcl_GetUnicodeFromObj( * * Tcl_GetRange -- * - * Create a Tcl Object that contains the chars between first and last of - * the object indicated by "objPtr". If the object is not already a - * String object, convert it to one. If first is TCL_INDEX_NONE, the - * returned string start at the beginning of objPtr. If last is - * TCL_INDEX_NONE, the returned string ends at the end of objPtr. + * Create a Tcl Object that contains the chars between first + * and last of the object indicated by "objPtr". If the object + * is not a byte-array object, and not already a String object, + * convert it to a String object. If first is TCL_INDEX_NONE, + * the returned string start at the beginning of objPtr. If + * last is TCL_INDEX_NONE, the returned string ends at the + * end of objPtr. * * Results: - * Returns a new Tcl Object of the String type. + * Returns a new Tcl Object of the String or byte-array type. * * Side effects: * Changes the internal rep of "objPtr" to the String type. @@ -721,7 +723,8 @@ Tcl_GetRange( Tcl_Size first, /* First index of the range. */ Tcl_Size last) /* Last index of the range. */ { - Tcl_Obj *newObjPtr; /* The Tcl object to find the range of. */ + Tcl_Obj *newObjPtr; /* The Tcl object to return that is the new + * range. */ String *stringPtr; Tcl_Size length = 0; @@ -730,7 +733,7 @@ Tcl_GetRange( } /* - * Optimize the case where we're really dealing with a bytearray object + * Optimize the case where we're really dealing with a byte-array object * we don't need to convert to a string to perform the substring operation. */ @@ -800,7 +803,8 @@ TclGetRange( Tcl_Size first, /* First index of the range. */ Tcl_Size last) /* Last index of the range. */ { - Tcl_Obj *newObjPtr; /* The Tcl object to find the range of. */ + Tcl_Obj *newObjPtr; /* The Tcl object to return that is the new + * range. */ Tcl_Size length = 0; if (first < 0) { @@ -808,7 +812,7 @@ TclGetRange( } /* - * Optimize the case where we're really dealing with a bytearray object + * Optimize the case where we're really dealing with a byte-array object * we don't need to convert to a string to perform the substring operation. */ @@ -1392,7 +1396,7 @@ Tcl_AppendObjToObj( if (TclIsPureByteArray(appendObjPtr) && (TclIsPureByteArray(objPtr) || objPtr->bytes == &tclEmptyString)) { /* - * Both bytearray objects are pure, so the second internal bytearray value + * Both byte-array objects are pure, so the second internal byte-array value * can be appended to the first, with no need to modify the "bytes" field. */ @@ -3004,7 +3008,7 @@ TclStringRepeat( /* * Analyze to determine what representation result should be. * GOALS: Avoid shimmering & string rep generation. - * Produce pure bytearray when possible. + * Produce pure byte-array when possible. * Error on overflow. */ @@ -3170,7 +3174,7 @@ TclStringCat( /* * Analyze to determine what representation result should be. * GOALS: Avoid shimmering & string rep generation. - * Produce pure bytearray when possible. + * Produce pure byte-array when possible. * Error on overflow. */ @@ -3184,8 +3188,8 @@ TclStringCat( /* Value has a string rep. */ if (objPtr->length) { /* - * Non-empty string rep. Not a pure bytearray, so we won't - * create a pure bytearray. + * Non-empty string rep. Not a pure byte-array, so we won't + * create a pure byte-array. */ binary = 0; @@ -3220,7 +3224,7 @@ TclStringCat( Tcl_Obj *objPtr = *ov++; /* - * Every argument is either a bytearray with a ("pure") + * Every argument is either a byte-array with a ("pure") * value we know we can safely use, or it is an empty string. * We don't need to count bytes for the empty strings. */ @@ -3378,7 +3382,7 @@ TclStringCat( Tcl_Obj *objPtr = *objv++; /* - * Every argument is either a bytearray with a ("pure") + * Every argument is either a byte-array with a ("pure") * value we know we can safely use, or it is an empty string. * We don't need to copy bytes from the empty strings. */ @@ -4200,7 +4204,7 @@ TclStringReplace( /* * The caller very likely had to call Tcl_GetCharLength() or similar * to be able to process index values. This means it is likely that - * objPtr is either a proper "bytearray" or a "string" or else it has + * objPtr is either a proper "byte-array" or a "string" or else it has * a known and short string rep. */ -- cgit v0.12 From 70c6034e0b9818065df355d5c5fb24947812d519 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 21 Feb 2025 22:55:45 +0000 Subject: * In-code comments reflect what is actually happening - eg: Tcl_GetRange() does *not* only convert the Obj values to a valid Unicode string, it will preserve a byte-array if a byte-array is what is passed in. * s/bytearray/byte-array/, consistent with (eg) Tcl_NewByteArrayObj(3) * update Tcl_GetRange(3) doc to reflect the byte-array -preserving aspect. --- doc/StringObj.3 | 13 +++++----- generic/tclStringObj.c | 64 +++++++++++++++++++++++++++----------------------- 2 files changed, 41 insertions(+), 36 deletions(-) diff --git a/doc/StringObj.3 b/doc/StringObj.3 index f53b670..f72c6a0 100644 --- a/doc/StringObj.3 +++ b/doc/StringObj.3 @@ -210,12 +210,13 @@ value's Unicode representation. If the index is out of range it returns -1; .PP \fBTcl_GetRange\fR returns a newly created value comprised of the -characters between \fIfirst\fR and \fIlast\fR (inclusive) in the value's -Unicode representation. If the value's Unicode representation -is invalid, the Unicode representation is regenerated from the value's -string representation. If \fIfirst\fR is negative, then the returned -string starts at the beginning of the value. If \fIlast\fR is negative, -then the returned string ends at the end of the value. +characters between \fIfirst\fR and \fIlast\fR (inclusive) in the +value's Unicode or byte-array representation. If the value is not +a byte-array and the values Unicode representation is invalid, the +Unicode representation is regenerated from the value's string +representation. If \fIfirst\fR is negative, then the returned +string starts at the beginning of the value. If \fIlast\fR is +negative, then the returned string ends at the end of the value. .PP \fBTcl_GetCharLength\fR returns the number of characters (as opposed to bytes) in the string value. diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 059f8dd..6b589da 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -388,14 +388,14 @@ Tcl_GetCharLength( } /* - * Optimize the case where we're really dealing with a bytearray object; + * Optimize the case where we're really dealing with a byte-array object; * we don't need to convert to a string to perform the get-length operation. * - * Starting in Tcl 8.7, we check for a "pure" bytearray, because the - * machinery behind that test is using a proper bytearray ObjType. We - * could also compute length of an improper bytearray without shimmering - * but there's no value in that. We *want* to shimmer an improper bytearray - * because improper bytearrays have worthless internal reps. + * Starting in Tcl 8.7, we check for a "pure" byte-array, because the + * machinery behind that test is using a proper byte-array ObjType. We + * could also compute length of an improper byte-array without shimmering + * but there's no value in that. We *want* to shimmer an improper byte-array + * because improper byte-arrays have worthless internal reps. */ if (TclIsPureByteArray(objPtr)) { @@ -439,14 +439,14 @@ TclGetCharLength( } /* - * Optimize the case where we're really dealing with a bytearray object; + * Optimize the case where we're really dealing with a byte-array object; * we don't need to convert to a string to perform the get-length operation. * - * Starting in Tcl 8.7, we check for a "pure" bytearray, because the - * machinery behind that test is using a proper bytearray ObjType. We - * could also compute length of an improper bytearray without shimmering - * but there's no value in that. We *want* to shimmer an improper bytearray - * because improper bytearrays have worthless internal reps. + * Starting in Tcl 8.7, we check for a "pure" byte-array, because the + * machinery behind that test is using a proper byte-array ObjType. We + * could also compute length of an improper byte-array without shimmering + * but there's no value in that. We *want* to shimmer an improper byte-array + * because improper byte-arrays have worthless internal reps. */ if (TclIsPureByteArray(objPtr)) { @@ -700,14 +700,16 @@ Tcl_GetUnicodeFromObj( * * Tcl_GetRange -- * - * Create a Tcl Object that contains the chars between first and last of - * the object indicated by "objPtr". If the object is not already a - * String object, convert it to one. If first is TCL_INDEX_NONE, the - * returned string start at the beginning of objPtr. If last is - * TCL_INDEX_NONE, the returned string ends at the end of objPtr. + * Create a Tcl Object that contains the chars between first + * and last of the object indicated by "objPtr". If the object + * is not a byte-array object, and not already a String object, + * convert it to a String object. If first is TCL_INDEX_NONE, + * the returned string start at the beginning of objPtr. If + * last is TCL_INDEX_NONE, the returned string ends at the + * end of objPtr. * * Results: - * Returns a new Tcl Object of the String type. + * Returns a new Tcl Object of the String or byte-array type. * * Side effects: * Changes the internal rep of "objPtr" to the String type. @@ -721,7 +723,8 @@ Tcl_GetRange( Tcl_Size first, /* First index of the range. */ Tcl_Size last) /* Last index of the range. */ { - Tcl_Obj *newObjPtr; /* The Tcl object to find the range of. */ + Tcl_Obj *newObjPtr; /* The Tcl object to return that is the new + * range. */ String *stringPtr; Tcl_Size length = 0; @@ -730,7 +733,7 @@ Tcl_GetRange( } /* - * Optimize the case where we're really dealing with a bytearray object + * Optimize the case where we're really dealing with a byte-array object * we don't need to convert to a string to perform the substring operation. */ @@ -800,7 +803,8 @@ TclGetRange( Tcl_Size first, /* First index of the range. */ Tcl_Size last) /* Last index of the range. */ { - Tcl_Obj *newObjPtr; /* The Tcl object to find the range of. */ + Tcl_Obj *newObjPtr; /* The Tcl object to return that is the new + * range. */ Tcl_Size length = 0; if (first < 0) { @@ -808,7 +812,7 @@ TclGetRange( } /* - * Optimize the case where we're really dealing with a bytearray object + * Optimize the case where we're really dealing with a byte-array object * we don't need to convert to a string to perform the substring operation. */ @@ -1392,7 +1396,7 @@ Tcl_AppendObjToObj( if (TclIsPureByteArray(appendObjPtr) && (TclIsPureByteArray(objPtr) || objPtr->bytes == &tclEmptyString)) { /* - * Both bytearray objects are pure, so the second internal bytearray value + * Both byte-array objects are pure, so the second internal byte-array value * can be appended to the first, with no need to modify the "bytes" field. */ @@ -3004,7 +3008,7 @@ TclStringRepeat( /* * Analyze to determine what representation result should be. * GOALS: Avoid shimmering & string rep generation. - * Produce pure bytearray when possible. + * Produce pure byte-array when possible. * Error on overflow. */ @@ -3170,7 +3174,7 @@ TclStringCat( /* * Analyze to determine what representation result should be. * GOALS: Avoid shimmering & string rep generation. - * Produce pure bytearray when possible. + * Produce pure byte-array when possible. * Error on overflow. */ @@ -3184,8 +3188,8 @@ TclStringCat( /* Value has a string rep. */ if (objPtr->length) { /* - * Non-empty string rep. Not a pure bytearray, so we won't - * create a pure bytearray. + * Non-empty string rep. Not a pure byte-array, so we won't + * create a pure byte-array. */ binary = 0; @@ -3220,7 +3224,7 @@ TclStringCat( Tcl_Obj *objPtr = *ov++; /* - * Every argument is either a bytearray with a ("pure") + * Every argument is either a byte-array with a ("pure") * value we know we can safely use, or it is an empty string. * We don't need to count bytes for the empty strings. */ @@ -3378,7 +3382,7 @@ TclStringCat( Tcl_Obj *objPtr = *objv++; /* - * Every argument is either a bytearray with a ("pure") + * Every argument is either a byte-array with a ("pure") * value we know we can safely use, or it is an empty string. * We don't need to copy bytes from the empty strings. */ @@ -4200,7 +4204,7 @@ TclStringReplace( /* * The caller very likely had to call Tcl_GetCharLength() or similar * to be able to process index values. This means it is likely that - * objPtr is either a proper "bytearray" or a "string" or else it has + * objPtr is either a proper "byte-array" or a "string" or else it has * a known and short string rep. */ -- cgit v0.12 From ae48cd402d40844f64f93f7d0b2010e5c8d4a8b2 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 23 Feb 2025 23:06:00 +0000 Subject: Eliminate TCL_MAJOR_VERSION usage. dde -> 1.5a0 --- .github/workflows/onefiledist.yml | 2 +- generic/tclIntDecls.h | 11 - generic/tclIntPlatDecls.h | 487 -------------------------------------- generic/tclOODecls.h | 10 - generic/tclPlatDecls.h | 93 -------- library/dde/pkgIndex.tcl | 15 +- tests/winDde.test | 4 +- win/Makefile.in | 2 +- win/configure | 4 +- win/configure.ac | 4 +- win/makefile.vc | 2 +- win/tclWinDde.c | 39 +-- win/tclWinReg.c | 38 --- 13 files changed, 14 insertions(+), 697 deletions(-) diff --git a/.github/workflows/onefiledist.yml b/.github/workflows/onefiledist.yml index b962642..a914932 100644 --- a/.github/workflows/onefiledist.yml +++ b/.github/workflows/onefiledist.yml @@ -54,7 +54,7 @@ jobs: url: ${{ steps.upload.outputs.artifact-url }} macos: name: macOS - runs-on: macos-14 + runs-on: macos-13 defaults: run: shell: bash diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 9f3b9f0..6d9a09a 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -1268,17 +1268,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..9c9fccc 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 diff --git a/generic/tclOODecls.h b/generic/tclOODecls.h index 68c5b2b..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 for 8.7 */ -# 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/tclPlatDecls.h b/generic/tclPlatDecls.h index b8243d2..22e230c 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,8 +123,6 @@ 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 @@ -223,6 +131,5 @@ extern const TclPlatStubs *tclPlatStubsPtr; #define Tcl_WinTCharToUtf(string, len, dsPtr) (Tcl_DStringInit(dsPtr), \ (char *)Tcl_Char16ToUtfDString((const unsigned short *)(string), ((((len) + 2) >> 1) - 1), (dsPtr))) #endif -#endif #endif /* _TCLPLATDECLS */ diff --git a/library/dde/pkgIndex.tcl b/library/dde/pkgIndex.tcl index ace1681..25125c8 100644 --- a/library/dde/pkgIndex.tcl +++ b/library/dde/pkgIndex.tcl @@ -1,12 +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 {![package vsatisfies [package provide Tcl] 8.7] - && [::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.5a0 \ + [list load [file join $dir tcl9dde15.dll] Dde] + diff --git a/tests/winDde.test b/tests/winDde.test index 038de62..74e3222 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.5a0} 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/win/Makefile.in b/win/Makefile.in index 7e1cdd7..2ba5870 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -158,7 +158,7 @@ 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 dde 1.5a0 [list load ${DDE_DLL_FILE}];\ package ifneeded registry 1.4a0 [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) diff --git a/win/configure b/win/configure index f67f6f6..8687c80 100755 --- a/win/configure +++ b/win/configure @@ -2414,9 +2414,9 @@ TCL_MINOR_VERSION=1 TCL_PATCH_LEVEL="a0" 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.4 diff --git a/win/configure.ac b/win/configure.ac index b974ef8..d951571 100644 --- a/win/configure.ac +++ b/win/configure.ac @@ -18,9 +18,9 @@ TCL_MINOR_VERSION=1 TCL_PATCH_LEVEL="a0" 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.4 diff --git a/win/makefile.vc b/win/makefile.vc index 3a4c4df..709f45b 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -553,7 +553,7 @@ 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 dde 1.5a0 [list load "$(TCLDDELIB:\=/)"] package ifneeded registry 1.4a0 [list load "$(TCLREGLIB:\=/)"] << diff --git a/win/tclWinDde.c b/win/tclWinDde.c index 12a10e6..0a4cb3f 100644 --- a/win/tclWinDde.c +++ b/win/tclWinDde.c @@ -79,7 +79,7 @@ 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.5a0" #define TCL_DDE_PACKAGE_NAME "dde" #define TCL_DDE_SERVICE_NAME L"TclEval" #define TCL_DDE_EXECUTE_RESULT L"$TCLEVAL$EXECUTE$RESULT" @@ -90,22 +90,6 @@ static int ddeIsServer = 0; 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 +122,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 +154,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 +181,6 @@ Dde_SafeInit( } return result; } -#if TCL_MAJOR_VERSION < 9 -int -Tcldde_SafeInit( - Tcl_Interp *interp) -{ - return Dde_SafeInit(interp); -} -#endif /* *---------------------------------------------------------------------- diff --git a/win/tclWinReg.c b/win/tclWinReg.c index ff9b7da..f20833a 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 @@ -186,14 +165,6 @@ Registry_Init( Tcl_SetAssocData(interp, REGISTRY_ASSOC_KEY, NULL, cmd); return Tcl_PkgProvideEx(interp, "registry", "1.4a0", 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 /* *---------------------------------------------------------------------- -- cgit v0.12 From d43a93d92ed0b56525f917a63566bb6b30c3fde6 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 24 Feb 2025 22:02:03 +0000 Subject: update README.md --- README.md | 11 +++-------- 1 file changed, 3 insertions(+), 8 deletions(-) diff --git a/README.md b/README.md index 60e85a3..35819a7 100644 --- a/README.md +++ b/README.md @@ -11,14 +11,9 @@ site](https://sourceforge.net/projects/tcl/files/Tcl/). [![Build Status](https://github.com/tcltk/tcl/actions/workflows/mac-build.yml/badge.svg?branch=main)](https://github.com/tcltk/tcl/actions/workflows/mac-build.yml?query=branch%3Amain)
9.0 (production release, daily build) -[![Build Status](https://github.com/tcltk/tcl/actions/workflows/linux-build.yml/badge.svg?branch=core-9-branch)](https://github.com/tcltk/tcl/actions/workflows/linux-build.yml?query=branch%3Acore-9-branch) -[![Build Status](https://github.com/tcltk/tcl/actions/workflows/win-build.yml/badge.svg?branch=core-9-branch)](https://github.com/tcltk/tcl/actions/workflows/win-build.yml?query=branch%3Acore-9-branch) -[![Build Status](https://github.com/tcltk/tcl/actions/workflows/mac-build.yml/badge.svg?branch=core-9-branch)](https://github.com/tcltk/tcl/actions/workflows/mac-build.yml?query=branch%3Acore-9-branch) -
-8.7 (in development, daily build) -[![Build Status](https://github.com/tcltk/tcl/actions/workflows/linux-build.yml/badge.svg?branch=core-8-branch)](https://github.com/tcltk/tcl/actions/workflows/linux-build.yml?query=branch%3Acore-8-branch) -[![Build Status](https://github.com/tcltk/tcl/actions/workflows/win-build.yml/badge.svg?branch=core-8-branch)](https://github.com/tcltk/tcl/actions/workflows/win-build.yml?query=branch%3Acore-8-branch) -[![Build Status](https://github.com/tcltk/tcl/actions/workflows/mac-build.yml/badge.svg?branch=core-8-branch)](https://github.com/tcltk/tcl/actions/workflows/mac-build.yml?query=branch%3Acore-8-branch) +[![Build Status](https://github.com/tcltk/tcl/actions/workflows/linux-build.yml/badge.svg?branch=core-9-0-branch)](https://github.com/tcltk/tcl/actions/workflows/linux-build.yml?query=branch%3Acore-9-0-branch) +[![Build Status](https://github.com/tcltk/tcl/actions/workflows/win-build.yml/badge.svg?branch=core-9-0-branch)](https://github.com/tcltk/tcl/actions/workflows/win-build.yml?query=branch%3Acore-9-0-branch) +[![Build Status](https://github.com/tcltk/tcl/actions/workflows/mac-build.yml/badge.svg?branch=core-9-0-branch)](https://github.com/tcltk/tcl/actions/workflows/mac-build.yml?query=branch%3Acore-9-0-branch) ## Contents 1. [Introduction](#intro) -- cgit v0.12 From 7532f625dd115d13de41c9e696cdf6f1124b270c Mon Sep 17 00:00:00 2001 From: bch Date: Tue, 25 Feb 2025 05:43:02 +0000 Subject: int -> Tcl_Size updates to Utf(3), minor markup update --- doc/Utf.3 | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/doc/Utf.3 b/doc/Utf.3 index fc7311e..14516e9 100644 --- a/doc/Utf.3 +++ b/doc/Utf.3 @@ -45,13 +45,13 @@ unsigned short * wchar_t * \fBTcl_UtfToWCharDString\fR(\fIsrc, numBytes, dsPtr\fR) .sp -int +Tcl_Size \fBTcl_Char16Len\fR(\fIutf16\fR) .sp -int +Tcl_Size \fBTcl_WCharLen\fR(\fIwcharStr\fR) .sp -int +Tcl_Size \fBTcl_UniCharLen\fR(\fIuniStr\fR) .sp int @@ -72,7 +72,7 @@ int int \fBTcl_UtfCharComplete\fR(\fIsrc, numBytes\fR) .sp -int +Tcl_Size \fBTcl_NumUtfChars\fR(\fIsrc, numBytes\fR) .sp const char * @@ -214,7 +214,7 @@ operate on sequences of \fBUTF-16\fR units instead of \fBTcl_UniChar\fR. characters. It accepts a null-terminated UTF-16 sequence and returns the number of UTF-16 units until the null. .PP -\fBTcl_WCharLen\fR corresponds to \fBstrlen\fR for wchar_t +\fBTcl_WCharLen\fR corresponds to \fBstrlen\fR for \fBwchar_t\fR characters. It accepts a null-terminated \fBwchar_t\fR sequence and returns the number of \fBwchar_t\fR units until the null. .PP -- cgit v0.12 From 28fbeaaa88ba1ba92a8143cdc2a77d6ab1ae497f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 25 Feb 2025 09:33:14 +0000 Subject: int -> Tcl_Size updates to Utf(3), minor markup update --- doc/Utf.3 | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/doc/Utf.3 b/doc/Utf.3 index fc7311e..14516e9 100644 --- a/doc/Utf.3 +++ b/doc/Utf.3 @@ -45,13 +45,13 @@ unsigned short * wchar_t * \fBTcl_UtfToWCharDString\fR(\fIsrc, numBytes, dsPtr\fR) .sp -int +Tcl_Size \fBTcl_Char16Len\fR(\fIutf16\fR) .sp -int +Tcl_Size \fBTcl_WCharLen\fR(\fIwcharStr\fR) .sp -int +Tcl_Size \fBTcl_UniCharLen\fR(\fIuniStr\fR) .sp int @@ -72,7 +72,7 @@ int int \fBTcl_UtfCharComplete\fR(\fIsrc, numBytes\fR) .sp -int +Tcl_Size \fBTcl_NumUtfChars\fR(\fIsrc, numBytes\fR) .sp const char * @@ -214,7 +214,7 @@ operate on sequences of \fBUTF-16\fR units instead of \fBTcl_UniChar\fR. characters. It accepts a null-terminated UTF-16 sequence and returns the number of UTF-16 units until the null. .PP -\fBTcl_WCharLen\fR corresponds to \fBstrlen\fR for wchar_t +\fBTcl_WCharLen\fR corresponds to \fBstrlen\fR for \fBwchar_t\fR characters. It accepts a null-terminated \fBwchar_t\fR sequence and returns the number of \fBwchar_t\fR units until the null. .PP -- cgit v0.12 From 275fb469b9fffa0d3350659075827551d4adb41d Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 26 Feb 2025 18:03:32 +0000 Subject: dup test names --- tests/expr.test | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/tests/expr.test b/tests/expr.test index 54995fb..b9484aa 100644 --- a/tests/expr.test +++ b/tests/expr.test @@ -7322,29 +7322,30 @@ foreach {v r} { -Inf infinite NaN nan } { - if {[regexp {[/\*]} $v]} { set v [expr $v] } - test expr-58.1($v)=$r "float classification: fpclassify($v) eq $r" { + set changed 0 + if {[regexp {[/\*]} $v]} { set v [expr $v]; set changed 1 } + test expr-58.1($v)=$r-$changed "float classification: fpclassify($v) eq $r" { fpclassify $v } $r - test expr-58.2($v) "float classification: isfinite($v)" { + test expr-58.2($v)-$changed "float classification: isfinite($v)" { expr {isfinite($v)} } [expr {$r ni {"infinite" "nan"}}] - test expr-58.3($v) "float classification: isinf($v)" { + test expr-58.3($v)-$changed "float classification: isinf($v)" { expr {isinf($v)} } [expr {$r eq "infinite"}] - test expr-58.4($v) "float classification: isnan($v)" { + test expr-58.4($v)-$changed "float classification: isnan($v)" { expr {isnan($v)} } [expr {$r eq "nan"}] - test expr-58.5($v) "float classification: isnormal($v)" { + test expr-58.5($v)-$changed "float classification: isnormal($v)" { expr {isnormal($v)} } [expr {$r eq "normal"}] - test expr-58.6($v) "float classification: issubnormal($v)" { + test expr-58.6($v)-$changed "float classification: issubnormal($v)" { expr {issubnormal($v)} } [expr {$r eq "subnormal"}] - test expr-58.7($v) "float classification: isunordered(0 and $v)" { + test expr-58.7($v)-$changed "float classification: isunordered(0 and $v)" { expr {isunordered(0,$v) + isunordered($v,0)} } [expr {$r eq "nan" ? 2 : 0}] - test expr-58.9($v) "float classification: isunordered(NaN and $v)" { + test expr-58.8($v)-$changed "float classification: isunordered(NaN and $v)" { expr {isunordered(NaN,$v) + isunordered($v,NaN)} } 2 } -- cgit v0.12 From 52e2e677d7cd81ead9dab8ccd5ed97d0d28f816b Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 26 Feb 2025 18:19:26 +0000 Subject: dup test names --- tests/expr.test | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/tests/expr.test b/tests/expr.test index 54995fb..b9484aa 100644 --- a/tests/expr.test +++ b/tests/expr.test @@ -7322,29 +7322,30 @@ foreach {v r} { -Inf infinite NaN nan } { - if {[regexp {[/\*]} $v]} { set v [expr $v] } - test expr-58.1($v)=$r "float classification: fpclassify($v) eq $r" { + set changed 0 + if {[regexp {[/\*]} $v]} { set v [expr $v]; set changed 1 } + test expr-58.1($v)=$r-$changed "float classification: fpclassify($v) eq $r" { fpclassify $v } $r - test expr-58.2($v) "float classification: isfinite($v)" { + test expr-58.2($v)-$changed "float classification: isfinite($v)" { expr {isfinite($v)} } [expr {$r ni {"infinite" "nan"}}] - test expr-58.3($v) "float classification: isinf($v)" { + test expr-58.3($v)-$changed "float classification: isinf($v)" { expr {isinf($v)} } [expr {$r eq "infinite"}] - test expr-58.4($v) "float classification: isnan($v)" { + test expr-58.4($v)-$changed "float classification: isnan($v)" { expr {isnan($v)} } [expr {$r eq "nan"}] - test expr-58.5($v) "float classification: isnormal($v)" { + test expr-58.5($v)-$changed "float classification: isnormal($v)" { expr {isnormal($v)} } [expr {$r eq "normal"}] - test expr-58.6($v) "float classification: issubnormal($v)" { + test expr-58.6($v)-$changed "float classification: issubnormal($v)" { expr {issubnormal($v)} } [expr {$r eq "subnormal"}] - test expr-58.7($v) "float classification: isunordered(0 and $v)" { + test expr-58.7($v)-$changed "float classification: isunordered(0 and $v)" { expr {isunordered(0,$v) + isunordered($v,0)} } [expr {$r eq "nan" ? 2 : 0}] - test expr-58.9($v) "float classification: isunordered(NaN and $v)" { + test expr-58.8($v)-$changed "float classification: isunordered(NaN and $v)" { expr {isunordered(NaN,$v) + isunordered($v,NaN)} } 2 } -- cgit v0.12 From 5baad7eda82035e68c69c0fed5b2c8dfdce543ce Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 26 Feb 2025 20:32:55 +0000 Subject: Possible fix for [a77029cdea]: MS-VS build system: pckIndex.tcl when building for 9 misses "t" for TCL 8.6 part --- win/rules.vc | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/win/rules.vc b/win/rules.vc index 170481f..6ba7018 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -1297,7 +1297,8 @@ tklibs = "$(TKSTUBLIB)" "$(TKIMPLIB)" # Various output paths PRJIMPLIB = $(OUT_DIR)\$(PROJECT)$(VERSION)$(SUFX).lib -PRJLIBNAME8 = $(PROJECT)$(VERSION)$(SUFX).$(EXT) +# Even when building against Tcl 9, PRJLIBNAME8 must have "t" +PRJLIBNAME8 = $(PROJECT)$(VERSION)t$(SUFX:t=).$(EXT) # Even when building against Tcl 8, PRJLIBNAME9 must not have "t" PRJLIBNAME9 = tcl9$(PROJECT)$(VERSION)$(SUFX:t=).$(EXT) !if $(TCL_MAJOR_VERSION) == 8 || "$(TCL_BUILD_FOR)" == "8" -- cgit v0.12 From 9eb4cedf83376a1b1cfa52c62c3800f9c923099c Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 26 Feb 2025 20:33:34 +0000 Subject: another one --- tests/zipfs.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/zipfs.test b/tests/zipfs.test index 97dba53..06aa5f6 100644 --- a/tests/zipfs.test +++ b/tests/zipfs.test @@ -669,7 +669,7 @@ namespace eval test_ns_zipfs { mount [zippath test.zip] set newmount [file join [zipfs root] test testdir] mount [zippath test-overlay.zip] $newmount - } -constraints bug-4ae42446ab -cleanup { + } -constraints bug_4ae42446ab -cleanup { cleanup } -body { # KNOWN BUG. The test2 file is also present in parent mount. -- cgit v0.12 From 74163d999b5c98fb62f26421390860bac3352dce Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 26 Feb 2025 20:45:46 +0000 Subject: More constraint name repair --- tests/bigdata.test | 18 +++++++++--------- tests/listObj.test | 2 +- 2 files changed, 10 insertions(+), 10 deletions(-) diff --git a/tests/bigdata.test b/tests/bigdata.test index a7db497..6b5b501 100644 --- a/tests/bigdata.test +++ b/tests/bigdata.test @@ -139,7 +139,7 @@ test script-bytecode-length-bigdata-1 {Test bytecode length limit} -body { catch $s r e } -cleanup { bigClean -} -constraints panic-in-EnterCmdStartData +} -constraints panicInEnterCmdStartData # # string cat @@ -321,7 +321,7 @@ bigtestRO string-map-bigdata-1 {string map} {5 0 0 5} -body { set s [bigString 0x100000000] } -cleanup { bigClean -} -constraints bug-takesTooLong +} -constraints bugTakesTooLong # # string match @@ -681,7 +681,7 @@ bigtestRO regexp-bigdata-2 "regexp with capture" 1 -body { set s [bigString 0x10000000a 0x100000009] } -cleanup { bigClean digits match -} -constraints bug-takesTooLong +} -constraints bugTakesTooLong # # regsub @@ -691,14 +691,14 @@ bigtestRO regsub-bigdata-1 "regsub" X -body { set s [bigString 0x100000001 0x100000000] } -cleanup { bigClean -} -constraints bug-takesTooLong +} -constraints bugTakesTooLong bigtestRO regsub-bigdata-2 "regsub" 1 -body { string equal [regsub -all \\d $s x] [string cat [string repeat x 0x100000000] X] } -setup { set s [bigString 0x100000001 0x100000000] } -cleanup { bigClean -} -constraints bug-takesTooLong +} -constraints bugTakesTooLong # # subst @@ -869,7 +869,7 @@ bigtest ledit-bigdata-3 "ledit - small -> large result" {2147483650 2147483650 { set l [bigList 2147483642] } -cleanup { bigClean -} -constraints memory-allocation-panic +} -constraints memoryAllocationPanic # # lindex @@ -1027,7 +1027,7 @@ bigtest lreplace-bigdata-2 "lreplace - large result" {4294967301 {a b c d e 0 1 #set l [bigList 4294967296] } -cleanup { bigClean -} -constraints bug-outofmemorypanic +} -constraints bugOutOfMemoryPanic # # lsearch @@ -1058,7 +1058,7 @@ bigtest lseq-bigdata-2 "lseq" {9223372036854775807 9223372036854775799} -body { set l [lseq 0x7fffffffffffffff]; llength $l } -cleanup { bigClean -} -constraints bug-fa00fbbbab +} -constraints bug_fa00fbbbab # # lset @@ -1103,7 +1103,7 @@ bigtest split-bigdata-1 "split" {4294967296 {0 1 2 3 4} {1 2 3 4 5}} -body { set s [bigString 0x100000000] } -cleanup { bigClean -} -constraints bug-takesTooLong +} -constraints bugTakesTooLong bigtestRO concat-bigdata-1 "concat" {4294967296 {0 1 2 3 4} {6 7 0 1 2} {3 4 5 6 7}} -body { unset -nocomplain l2 diff --git a/tests/listObj.test b/tests/listObj.test index 7aac480..087747f 100644 --- a/tests/listObj.test +++ b/tests/listObj.test @@ -319,7 +319,7 @@ test listobj-14.2 {Tcl_ListObjIndex out-of-bounds index for native lists with sp 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 { +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 -- cgit v0.12 From 6dcc8167f2562ad7d1e02274355f7cbb79ddbf68 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 2 Mar 2025 15:48:58 +0000 Subject: Bunch of whitespace basic fixes. --- generic/tcl.h | 4 +- generic/tclArithSeries.c | 31 +++++++------- generic/tclAssembly.c | 8 ++-- generic/tclAsync.c | 7 ++-- generic/tclBasic.c | 19 ++++----- generic/tclCkalloc.c | 1 - generic/tclClock.c | 6 +-- generic/tclCmdAH.c | 10 ++--- generic/tclCmdIL.c | 17 ++++---- generic/tclCmdMZ.c | 2 +- generic/tclCompCmds.c | 4 +- generic/tclCompCmdsSZ.c | 4 +- generic/tclCompExpr.c | 4 +- generic/tclCompile.c | 18 ++++---- generic/tclConfig.c | 2 +- generic/tclDictObj.c | 2 +- generic/tclDisassemble.c | 2 +- generic/tclEnv.c | 2 +- generic/tclEvent.c | 20 ++++----- generic/tclIO.c | 32 +++++++------- generic/tclIO.h | 2 +- generic/tclIOCmd.c | 10 ++--- generic/tclIOGT.c | 12 +++--- generic/tclIORChan.c | 16 +++---- generic/tclIORTrans.c | 8 ++-- generic/tclIOUtil.c | 16 +++---- generic/tclIcu.c | 37 ++++++++--------- generic/tclIndexObj.c | 10 ++--- generic/tclInt.h | 4 +- generic/tclLink.c | 4 +- generic/tclListObj.c | 54 ++++++++++++------------ generic/tclLiteral.c | 14 +++---- generic/tclMain.c | 4 +- generic/tclNamesp.c | 4 +- generic/tclNotify.c | 18 ++++---- generic/tclOODefineCmds.c | 1 - generic/tclOOInt.h | 2 +- generic/tclObj.c | 92 ++++++++++++++++++++--------------------- generic/tclPathObj.c | 32 +++++++------- generic/tclPipe.c | 1 - generic/tclStrToD.c | 2 +- generic/tclStringObj.c | 4 +- generic/tclStringRep.h | 2 +- generic/tclTest.c | 101 ++++++++++++++++++++++----------------------- generic/tclTestABSList.c | 20 ++++----- generic/tclTestObj.c | 18 ++++---- generic/tclThread.c | 7 ++-- generic/tclThreadStorage.c | 2 +- generic/tclThreadTest.c | 1 - generic/tclTimer.c | 14 +++---- generic/tclTrace.c | 50 +++++++++++----------- generic/tclUtf.c | 24 +++++------ generic/tclUtil.c | 100 ++++++++++++++++++++++---------------------- generic/tclZipfs.c | 2 +- macosx/tclMacOSXFCmd.c | 8 ++-- macosx/tclMacOSXNotify.c | 6 +-- unix/tclEpollNotfy.c | 6 +-- unix/tclKqueueNotfy.c | 6 +-- unix/tclLoadDyld.c | 8 ++-- unix/tclSelectNotfy.c | 4 +- unix/tclUnixChan.c | 18 +++----- unix/tclUnixFCmd.c | 19 ++++----- unix/tclUnixFile.c | 8 ++-- unix/tclUnixInit.c | 2 +- unix/tclUnixPipe.c | 14 +++---- unix/tclUnixSock.c | 36 ++++++++-------- unix/tclUnixTest.c | 2 +- unix/tclUnixThrd.c | 6 +-- unix/tclXtNotify.c | 4 +- win/tclWinChan.c | 32 +++++++------- win/tclWinConsole.c | 6 +-- win/tclWinDde.c | 16 +++---- win/tclWinFCmd.c | 3 +- win/tclWinFile.c | 4 +- win/tclWinInit.c | 2 +- win/tclWinNotify.c | 4 +- win/tclWinPipe.c | 21 +++++----- win/tclWinReg.c | 6 +-- 78 files changed, 544 insertions(+), 580 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index 31916df..40bfd21 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -408,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. */ @@ -679,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, */ diff --git a/generic/tclArithSeries.c b/generic/tclArithSeries.c index 92cf611..a63a53a 100755 --- a/generic/tclArithSeries.c +++ b/generic/tclArithSeries.c @@ -227,9 +227,8 @@ ObjPrecision( int type; if (TclHasInternalRep(numObj, &tclDoubleType) || ( - Tcl_GetNumberFromObj(NULL, numObj, &ptr, &type) == TCL_OK && - type == TCL_NUMBER_DOUBLE - ) + Tcl_GetNumberFromObj(NULL, numObj, &ptr, &type) == TCL_OK + && type == TCL_NUMBER_DOUBLE) ) { /* TCL_NUMBER_DOUBLE */ const char *str = TclGetString(numObj); @@ -338,10 +337,8 @@ ArithSeriesLenDbl( * To improve numerical stability use wide arithmetic instead of IEEE-754 * when distance and step do not exceed wide-integers. */ - if ( - ((double)WIDE_MIN <= end && end <= (double)WIDE_MAX) && - ((double)WIDE_MIN <= step && step <= (double)WIDE_MAX) - ) { + if (((double)WIDE_MIN <= end && end <= (double)WIDE_MAX) && + ((double)WIDE_MIN <= step && step <= (double)WIDE_MAX)) { Tcl_WideInt iend = end < 0 ? end - 0.5 : end + 0.5; Tcl_WideInt istep = step < 0 ? step - 0.5 : step + 0.5; if (istep) { /* avoid div by zero, steps like 0.1, precision 0 */ @@ -629,13 +626,13 @@ assignNumber( */ Tcl_Obj * TclNewArithSeriesObj( - Tcl_Interp *interp, /* For error reporting */ - int useDoubles, /* Flag indicates values start, - ** end, step, are treated as doubles */ - Tcl_Obj *startObj, /* Starting value */ - Tcl_Obj *endObj, /* Ending limit */ - Tcl_Obj *stepObj, /* increment value */ - Tcl_Obj *lenObj) /* Number of elements */ + Tcl_Interp *interp, /* For error reporting */ + int useDoubles, /* Flag indicates values start, + * end, step, are treated as doubles */ + Tcl_Obj *startObj, /* Starting value */ + Tcl_Obj *endObj, /* Ending limit */ + Tcl_Obj *stepObj, /* increment value */ + Tcl_Obj *lenObj) /* Number of elements */ { double dstart, dend, dstep = 1.0; Tcl_WideInt start, end, step = 1; @@ -876,11 +873,11 @@ SetArithSeriesFromAny( int TclArithSeriesObjRange( - Tcl_Interp *interp, /* For error message(s) */ + Tcl_Interp *interp, /* For error message(s) */ Tcl_Obj *arithSeriesObj, /* List object to take a range from. */ Tcl_Size fromIdx, /* Index of first element to include. */ Tcl_Size toIdx, /* Index of last element to include. */ - Tcl_Obj **newObjPtr) /* return value */ + Tcl_Obj **newObjPtr) /* return value */ { ArithSeries *arithSeriesRepPtr; Tcl_WideInt len; @@ -1066,7 +1063,7 @@ TclArithSeriesGetElements( */ int TclArithSeriesObjReverse( - Tcl_Interp *interp, /* For error message(s) */ + Tcl_Interp *interp, /* For error message(s) */ Tcl_Obj *arithSeriesObj, /* List object to reverse. */ Tcl_Obj **newObjPtr) { diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 7283b0a..6575934 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -222,9 +222,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 + Tcl_Size 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 */ @@ -1266,7 +1266,7 @@ 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 */ @@ -1963,7 +1963,7 @@ 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_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 */ diff --git a/generic/tclAsync.c b/generic/tclAsync.c index f0f0c9c..dfed6ec 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); @@ -201,7 +201,6 @@ Tcl_AsyncMark( Tcl_ThreadAlert(token->originThrdId); } Tcl_MutexUnlock(&asyncMutex); - } /* diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 6c73ed0..73eb602 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -2717,9 +2717,9 @@ 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; @@ -3006,9 +3006,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; @@ -3550,7 +3550,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 +3947,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. */ { @@ -8088,7 +8087,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; @@ -8179,10 +8178,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; } diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c index bf2b12c..497392d 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); } - } /* diff --git a/generic/tclClock.c b/generic/tclClock.c index 31e12e4..0c37e6a 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -115,7 +115,7 @@ struct ClockCommand { const char *name; /* The tail of the command name. The full name * is "::tcl::clock::". When NULL marks * the end of the table. */ - Tcl_ObjCmdProc *objCmdProc; /* Function that implements the command. This + Tcl_ObjCmdProc *objCmdProc; /* Function that implements the command. This * will always have the ClockClientData sent * to it, but may well ignore this data. */ CompileProc *compileProc; /* The compiler for the command. */ @@ -340,7 +340,7 @@ ClockConfigureClear( */ static void ClockDeleteCmdProc( - void *clientData) /* Opaque pointer to the client data */ + void *clientData) /* Opaque pointer to the client data */ { ClockClientData *data = (ClockClientData *)clientData; int i; @@ -3276,7 +3276,7 @@ ClockParseFmtScnArgs( ClockFmtScnCmdArgs *opts, /* Result vector: format, locale, timezone... */ TclDateFields *date, /* Extracted date-time corresponding base * (by scan or add) resp. clockval (by format) */ - Tcl_Size objc, /* Parameter count */ + Tcl_Size objc, /* Parameter count */ Tcl_Obj *const objv[], /* Parameter vector */ ClockOperation operation, /* What operation are we doing: format, scan, add */ const char *syntax) /* Syntax of the current command */ diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index ea98a83..baaf949 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -524,7 +524,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; @@ -593,7 +593,6 @@ EncodingConvertfromObjCmd( Tcl_FreeEncoding(encoding); return TCL_OK; - } /* @@ -686,7 +685,6 @@ EncodingConverttoObjCmd( Tcl_FreeEncoding(encoding); return TCL_OK; - } /* @@ -752,9 +750,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); diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index b3d5fe9..a46f6d9 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -4037,11 +4037,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; @@ -4085,8 +4085,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 +4133,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; diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 8b59e34..4bdd6ad 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -5340,7 +5340,7 @@ TclListLines( Tcl_Size 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 + 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 39786ad..28e4247 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -2964,7 +2964,7 @@ 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; @@ -3013,7 +3013,7 @@ 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; diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 38fd8d6..313cb58 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -2115,7 +2115,7 @@ IssueSwitchChainedTests( * 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 + Tcl_Size *bodyLines, /* Array of line numbers for body list * items. */ Tcl_Size **bodyContLines) /* Array of continuation line info. */ { @@ -2363,7 +2363,7 @@ IssueSwitchJumpTable( * 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 + Tcl_Size *bodyLines, /* Array of line numbers for body list * items. */ Tcl_Size **bodyContLines) /* Array of continuation line info. */ { diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index ff03f87..e36df94 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -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, diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 35238d8..881c356 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -779,7 +779,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 @@ -2833,7 +2833,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; @@ -2978,7 +2978,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; @@ -3023,7 +3023,7 @@ TclInitByteCodeObj( Tcl_Size 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. */ @@ -3202,7 +3202,7 @@ 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; @@ -3280,8 +3280,8 @@ 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; @@ -3764,11 +3764,11 @@ TclFinalizeLoopExceptionRange( Tcl_Size 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. */ diff --git a/generic/tclConfig.c b/generic/tclConfig.c index a297545..689e807 100644 --- a/generic/tclConfig.c +++ b/generic/tclConfig.c @@ -391,7 +391,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/tclDictObj.c b/generic/tclDictObj.c index 6216430..b1249e8 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -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, diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index 6b0b5f1..ffc3026 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -1261,7 +1261,7 @@ DisassembleByteCodeAsDicts( int Tcl_DisassembleObjCmd( - void *clientData, /* What type of operation. */ + void *clientData, /* What type of operation. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ 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 4dd10d8..9a8069e 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -72,7 +72,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 +122,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 */ @@ -212,7 +212,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; @@ -600,7 +600,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 +639,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 +672,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 +705,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 +748,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 +791,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 +824,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); diff --git a/generic/tclIO.c b/generic/tclIO.c index f632d4a..77b9475 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -69,7 +69,7 @@ typedef struct GetsState { char **dstPtr; /* Pointer into objPtr's string rep where * next character should be stored. */ Tcl_Encoding encoding; /* The encoding to use to convert raw bytes - * to UTF-8. */ + * to UTF-8. */ ChannelBuffer *bufPtr; /* The current buffer of raw bytes being * emptied. */ Tcl_EncodingState state; /* The encoding state just before the last @@ -847,7 +847,7 @@ Tcl_CreateCloseHandler( * callback. */ Tcl_CloseProc *proc, /* The callback routine to call when the * channel will be closed. */ - void *clientData) /* Arbitrary data to pass to the close + void *clientData) /* Arbitrary data to pass to the close * callback. */ { ChannelState *statePtr = ((Channel *) chan)->state; @@ -885,7 +885,7 @@ Tcl_DeleteCloseHandler( * callback. */ Tcl_CloseProc *proc, /* The procedure for the callback to * remove. */ - void *clientData) /* The callback data for the callback to + void *clientData) /* The callback data for the callback to * remove. */ { ChannelState *statePtr = ((Channel *) chan)->state; @@ -984,7 +984,7 @@ GetChannelTable( static void DeleteChannelTable( - void *clientData, /* The per-interpreter data structure. */ + void *clientData, /* The per-interpreter data structure. */ Tcl_Interp *interp) /* The interpreter being deleted. */ { Tcl_HashTable *hTblPtr; /* The hash table. */ @@ -2493,7 +2493,7 @@ Tcl_RemoveChannelMode( static ChannelBuffer * AllocChannelBuffer( - Tcl_Size length) /* Desired length of channel buffer. */ + Tcl_Size length) /* Desired length of channel buffer. */ { ChannelBuffer *bufPtr; Tcl_Size n; @@ -4062,7 +4062,7 @@ Tcl_Size Tcl_Write( Tcl_Channel chan, /* The channel to buffer output for. */ const char *src, /* Data to queue in output buffer. */ - Tcl_Size srcLen) /* Length of data in bytes, or TCL_INDEX_NONE for + Tcl_Size srcLen) /* Length of data in bytes, or TCL_INDEX_NONE for * strlen(). */ { /* @@ -4174,7 +4174,7 @@ Tcl_WriteChars( Tcl_Channel chan, /* The channel to buffer output for. */ const char *src, /* UTF-8 characters to queue in output * buffer. */ - Tcl_Size len) /* Length of string in bytes, or TCL_INDEX_NONE for + Tcl_Size len) /* Length of string in bytes, or TCL_INDEX_NONE for * strlen(). */ { Channel *chanPtr = (Channel *) chan; @@ -4352,7 +4352,7 @@ static Tcl_Size Write( Channel *chanPtr, /* The channel to buffer output for. */ const char *src, /* UTF-8 string to write. */ - Tcl_Size srcLen, /* Length of UTF-8 string in bytes. */ + Tcl_Size srcLen, /* Length of UTF-8 string in bytes. */ Tcl_Encoding encoding) { ChannelState *statePtr = chanPtr->state; @@ -5715,7 +5715,7 @@ Tcl_Size Tcl_Read( Tcl_Channel chan, /* The channel from which to read. */ char *dst, /* Where to store input read. */ - Tcl_Size bytesToRead) /* Maximum number of bytes to read. */ + Tcl_Size bytesToRead) /* Maximum number of bytes to read. */ { Channel *chanPtr = (Channel *) chan; ChannelState *statePtr = chanPtr->state; @@ -5760,7 +5760,7 @@ Tcl_Size Tcl_ReadRaw( Tcl_Channel chan, /* The channel from which to read. */ char *readBuf, /* Where to store input read. */ - Tcl_Size bytesToRead) /* Maximum number of bytes to read. */ + Tcl_Size bytesToRead) /* Maximum number of bytes to read. */ { Channel *chanPtr = (Channel *) chan; ChannelState *statePtr = chanPtr->state; @@ -6822,7 +6822,7 @@ Tcl_Size Tcl_Ungets( Tcl_Channel chan, /* The channel for which to add the input. */ const char *str, /* The input itself. */ - Tcl_Size len, /* The length of the input. */ + Tcl_Size len, /* The length of the input. */ int atEnd) /* If non-zero, add at end of queue; otherwise * add at head of queue. */ { @@ -7795,7 +7795,7 @@ Tcl_ChannelBuffered( void Tcl_SetChannelBufferSize( Tcl_Channel chan, /* The channel whose buffer size to set. */ - Tcl_Size sz) /* The size to set. */ + Tcl_Size sz) /* The size to set. */ { ChannelState *statePtr; /* State of real channel structure. */ @@ -8869,7 +8869,7 @@ Tcl_CreateChannelHandler( * handler. */ Tcl_ChannelProc *proc, /* Procedure to call for each selected * event. */ - void *clientData) /* Arbitrary data to pass to proc. */ + void *clientData) /* Arbitrary data to pass to proc. */ { ChannelHandler *chPtr; Channel *chanPtr = (Channel *) chan; @@ -8941,7 +8941,7 @@ Tcl_DeleteChannelHandler( Tcl_Channel chan, /* The channel for which to remove the * callback. */ Tcl_ChannelProc *proc, /* The procedure in the callback to delete. */ - void *clientData) /* The client data in the callback to + void *clientData) /* The client data in the callback to * delete. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -9147,7 +9147,7 @@ CreateScriptRecord( void TclChannelEventScriptInvoker( - void *clientData, /* The script+interp record. */ + void *clientData, /* The script+interp record. */ TCL_UNUSED(int) /*mask*/) { EventScriptRecord *esPtr = (EventScriptRecord *)clientData; @@ -10063,7 +10063,7 @@ static Tcl_Size DoRead( Channel *chanPtr, /* The channel from which to read. */ char *dst, /* Where to store input read. */ - Tcl_Size bytesToRead, /* Maximum number of bytes to read. */ + Tcl_Size bytesToRead, /* Maximum number of bytes to read. */ int allowShortReads) /* Allow half-blocking (pipes,sockets) */ { ChannelState *statePtr = chanPtr->state; diff --git a/generic/tclIO.h b/generic/tclIO.h index 06e49a5..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. */ diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index 712447b..707039e 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -369,8 +369,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; @@ -1239,7 +1239,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 *)) { @@ -1367,7 +1367,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 @@ -1458,7 +1458,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..f9a1d11 100644 --- a/generic/tclIOGT.c +++ b/generic/tclIOGT.c @@ -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; @@ -1013,7 +1013,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 +1091,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 +1125,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 +1170,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 beb4d2c..5fc414a 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", /* */ @@ -1778,7 +1778,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 +1850,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 */ @@ -2003,7 +2003,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 +2086,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. */ @@ -2563,13 +2563,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..ad55a39 100644 --- a/generic/tclIORTrans.c +++ b/generic/tclIORTrans.c @@ -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/tclIOUtil.c b/generic/tclIOUtil.c index 317e9c0..41d1a33 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) @@ -1323,8 +1323,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; @@ -2912,7 +2912,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 @@ -3377,7 +3377,7 @@ Tcl_LoadFile( tvdlPtr->unloadProcPtr = newUnloadProcPtr; if (copyFsPtr != &tclNativeFilesystem) { - /* refCount of copyToPtr is already incremented. */ + /* refCount of copyToPtr is already incremented. */ tvdlPtr->divertedFile = copyToPtr; /* @@ -4341,7 +4341,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 @@ -4460,7 +4460,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 1dd901b..3d86f83 100644 --- a/generic/tclIcu.c +++ b/generic/tclIcu.c @@ -743,10 +743,10 @@ IcuConverterAliasesObjCmd( static int IcuConverttoDString( Tcl_Interp *interp, - Tcl_DString *dsInPtr, /* Input UTF16 */ + Tcl_DString *dsInPtr, /* Input UTF16 */ const char *icuEncName, int strict, - Tcl_DString *dsOutPtr) /* Output encoded string. */ + Tcl_DString *dsOutPtr) /* Output encoded string. */ { if (ucnv_open == NULL || ucnv_close == NULL || ucnv_fromUChars == NULL || UCNV_FROM_U_CALLBACK_STOP == NULL) { @@ -827,7 +827,7 @@ IcuBytesToUCharDString( Tcl_Size nbytes, const char *icuEncName, int strict, - Tcl_DString *dsOutPtr) /* Output UChar string. */ + Tcl_DString *dsOutPtr) /* Output UChar string. */ { if (ucnv_open == NULL || ucnv_close == NULL || ucnv_toUChars == NULL || UCNV_TO_U_CALLBACK_STOP == NULL) { @@ -855,7 +855,7 @@ IcuBytesToUCharDString( } int dstLen; - int dstCapacity = (int) nbytes; /* In UChar's */ + int dstCapacity = (int) nbytes; /* In UChar's */ Tcl_DStringInit(dsOutPtr); Tcl_DStringSetLength(dsOutPtr, dstCapacity); dstLen = ucnv_toUChars(ucnvPtr, (UCharx *)Tcl_DStringValue(dsOutPtr), dstCapacity, @@ -905,9 +905,9 @@ IcuBytesToUCharDString( static int IcuNormalizeUCharDString( Tcl_Interp *interp, - Tcl_DString *dsInPtr, /* Input UTF16 */ + Tcl_DString *dsInPtr, /* Input UTF16 */ NormalizationMode mode, - Tcl_DString *dsOutPtr) /* Output normalized UTF16. */ + Tcl_DString *dsOutPtr) /* Output normalized UTF16. */ { typedef UNormalizer2 *(*normFn)(UErrorCodex *); normFn fn = NULL; @@ -1060,9 +1060,9 @@ static int IcuParseConvertOptions( static int IcuConvertfromObjCmd( 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. */ { int strict; Tcl_Obj *failindexVar; @@ -1111,9 +1111,9 @@ IcuConvertfromObjCmd( static int IcuConverttoObjCmd( 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. */ { int strict; Tcl_Obj *failindexVar; @@ -1156,9 +1156,9 @@ IcuConverttoObjCmd( static int IcuNormalizeObjCmd( 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 *optNames[] = {"-profile", "-mode", NULL}; enum { OPT_PROFILE, OPT_MODE } opt; @@ -1271,10 +1271,9 @@ TclIcuCleanup( */ static void * IcuFindSymbol( - Tcl_LoadHandle loadH, /* Handle to shared library containing symbol */ - const char *name, /* Name of function */ - const char *suffix /* Suffix that may be present */ -) + Tcl_LoadHandle loadH, /* Handle to shared library containing symbol */ + const char *name, /* Name of function */ + const char *suffix) /* Suffix that may be present */ { /* * ICU symbols may have a version suffix depending on how it was built. diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index 2dbc6f6..f41a537 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; @@ -806,7 +806,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 @@ -1009,13 +1009,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. */ diff --git a/generic/tclInt.h b/generic/tclInt.h index 49da289..004c2a9 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1422,7 +1422,7 @@ typedef struct CFWordBC { typedef struct ContLineLoc { Tcl_Size num; /* Number of entries in loc, not counting the * final -1 marker entry. */ - Tcl_Size loc[TCLFLEXARRAY];/* Table of locations, as character offsets. + Tcl_Size loc[TCLFLEXARRAY]; /* Table of locations, as character offsets. * The table is allocated as part of the * structure, extending behind the nominal end * of the structure. An entry containing the @@ -2895,7 +2895,7 @@ typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, typedef struct ProcessGlobalValue { Tcl_Size epoch; /* Epoch counter to detect changes in the * global value. */ - size_t 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. */ diff --git a/generic/tclLink.c b/generic/tclLink.c index d2fb2af..14bb663 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 36914bc..ba8b1ba 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -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( @@ -1258,10 +1258,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; @@ -1460,7 +1460,7 @@ ListRepRange( *rangeRepPtr = *srcRepPtr; /* Not 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); @@ -2017,9 +2017,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; @@ -2727,7 +2727,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; } @@ -2784,10 +2784,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; /* @@ -3157,7 +3157,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. */ diff --git a/generic/tclLiteral.c b/generic/tclLiteral.c index 6720515..83323ba 100644 --- a/generic/tclLiteral.c +++ b/generic/tclLiteral.c @@ -176,11 +176,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, @@ -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 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 65b91f1..8e95f89 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -2303,7 +2303,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. */ @@ -5021,7 +5021,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..8d92f1f 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); @@ -394,7 +394,7 @@ Tcl_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. */ { 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); @@ -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/tclOODefineCmds.c b/generic/tclOODefineCmds.c index efc88bd..f817d29 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -2497,7 +2497,6 @@ ClassMixin_Get( } Tcl_SetObjResult(interp, resultObj); return TCL_OK; - } static int diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index ec91971..fb61ab1 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -259,7 +259,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 diff --git a/generic/tclObj.c b/generic/tclObj.c index d8513de..7e6e4b2 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 @@ -1662,9 +1662,9 @@ Tcl_GetString( #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. */ { @@ -1707,7 +1707,7 @@ TclGetStringFromObj( #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 +1790,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 +1861,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 +1973,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 +2000,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; @@ -2087,9 +2087,9 @@ 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); } @@ -2117,7 +2117,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 +2163,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 +2305,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 +2314,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; @@ -2434,9 +2434,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 { @@ -2576,9 +2576,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 +2648,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 +2680,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 +2814,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 +2824,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; @@ -3024,10 +3022,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 +3122,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 +3206,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 +3270,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 +3582,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 +3617,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 +3642,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; diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index db1a96a..82287cf 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 @@ -2566,11 +2566,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; diff --git a/generic/tclPipe.c b/generic/tclPipe.c index 1efe1ba..5487a57 100644 --- a/generic/tclPipe.c +++ b/generic/tclPipe.c @@ -194,7 +194,6 @@ Tcl_DetachPids( detList = detPtr; } Tcl_MutexUnlock(&pipeMutex); - } /* diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index 460df40..911ff1f 100644 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -583,7 +583,7 @@ TclParseNumber( const char *before, *after; if (p==bytes) { - /* Not allowed at beginning */ + /* Not allowed at beginning */ goto endgame; } /* diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 987ab76..72206d6 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -724,7 +724,7 @@ Tcl_GetRange( Tcl_Size last) /* Last index of the range. */ { Tcl_Obj *newObjPtr; /* The Tcl object to return that is the new - * range. */ + * range. */ String *stringPtr; Tcl_Size length = 0; @@ -804,7 +804,7 @@ TclGetRange( Tcl_Size last) /* Last index of the range. */ { Tcl_Obj *newObjPtr; /* The Tcl object to return that is the new - * range. */ + * range. */ Tcl_Size length = 0; if (first < 0) { 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/tclTest.c b/generic/tclTest.c index b616825..660bf53 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -952,7 +952,7 @@ 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. */ @@ -1014,7 +1014,7 @@ 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; @@ -1071,7 +1071,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; @@ -1108,7 +1108,7 @@ 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 @@ -1221,7 +1221,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*/) @@ -1233,7 +1233,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*/) @@ -1244,7 +1244,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*/) @@ -1255,7 +1255,7 @@ CmdProc2( static void CmdDelProc0( - void *clientData) /* String to save. */ + void *clientData) /* String to save. */ { TestCommandTokenRef *thisRefPtr, *prevRefPtr = NULL; TestCommandTokenRef *refPtr = (TestCommandTokenRef *) clientData; @@ -1277,7 +1277,7 @@ CmdDelProc0( static void CmdDelProc1( - void *clientData) /* String to save. */ + void *clientData) /* String to save. */ { Tcl_DStringInit(&delString); Tcl_DStringAppend(&delString, "CmdDelProc1 ", -1); @@ -1286,7 +1286,7 @@ CmdDelProc1( static void CmdDelProc2( - void *clientData) /* String to save. */ + void *clientData) /* String to save. */ { Tcl_DStringInit(&delString); Tcl_DStringAppend(&delString, "CmdDelProc2 ", -1); @@ -1484,12 +1484,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. */ @@ -1709,7 +1709,7 @@ 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); @@ -1771,7 +1771,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*/) @@ -1786,7 +1786,7 @@ DelCmdProc( static void DelDeleteProc( - void *clientData) /* String command to evaluate. */ + void *clientData) /* String command to evaluate. */ { DelCmd *dPtr = (DelCmd *)clientData; @@ -2047,9 +2047,9 @@ TestdstringCmd( static void SpecialFree( #if TCL_MAJOR_VERSION > 8 - void *blockPtr /* Block to free. */ + void *blockPtr /* Block to free. */ #else - char *blockPtr /* Block to free. */ + char *blockPtr /* Block to free. */ #endif ) { Tcl_Free(((char *)blockPtr) - 16); @@ -2189,11 +2189,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) { @@ -2383,7 +2382,7 @@ TestencodingCmd( 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*/, @@ -2415,7 +2414,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*/, @@ -2447,7 +2446,7 @@ EncodingFromUtfProc( static void EncodingFreeProc( - void *clientData) /* ClientData associated with type. */ + void *clientData) /* ClientData associated with type. */ { TclEncoding *encodingPtr = (TclEncoding *)clientData; @@ -2706,7 +2705,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 */ @@ -2779,7 +2778,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; @@ -2793,7 +2792,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; @@ -3668,9 +3667,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 @@ -3787,9 +3786,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[] = { @@ -4001,7 +4000,7 @@ TestlocaleCmd( static void CleanupTestSetassocdataTests( - void *clientData, /* Data to be released. */ + void *clientData, /* Data to be released. */ TCL_UNUSED(Tcl_Interp *)) { Tcl_Free(clientData); @@ -5805,8 +5804,8 @@ 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. */ { @@ -5836,8 +5835,8 @@ 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. */ { @@ -6015,7 +6014,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 */ @@ -6715,7 +6714,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..?"); @@ -6830,7 +6829,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; @@ -7611,8 +7610,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 ; @@ -8354,11 +8352,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) * @@ -8440,7 +8436,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; @@ -8602,10 +8598,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]; diff --git a/generic/tclTestABSList.c b/generic/tclTestABSList.c index 7e853e4..7ce98cd 100644 --- a/generic/tclTestABSList.c +++ b/generic/tclTestABSList.c @@ -50,11 +50,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; /* @@ -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; /* diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index d4cebbb..c7a9704 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -593,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; @@ -921,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; @@ -1613,9 +1613,9 @@ 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 @@ -1834,9 +1834,9 @@ CheckIfVarUnset( static int TestisemptyCmd ( 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. */ { Tcl_Obj *result; if (objc != 2) { 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/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 52493c1..90b4ccf 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 5ffb29b..42221f0 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 @@ -73,7 +73,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 +251,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 +619,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 +663,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; @@ -1149,7 +1149,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; @@ -1251,7 +1251,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 f396245..4d7e7d5 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 @@ -146,7 +146,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; @@ -279,8 +279,8 @@ Tcl_TraceObjCmd( static int TraceExecutionObjCmd( Tcl_Interp *interp, /* Current interpreter. */ - enum traceOptionsEnum optionIndex, /* Add, info or remove */ - Tcl_Size objc, /* Number of arguments. */ + enum traceOptionsEnum optionIndex, /* Add, info or remove */ + Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { const char *name, *command; @@ -526,8 +526,8 @@ TraceExecutionObjCmd( static int TraceCommandObjCmd( Tcl_Interp *interp, /* Current interpreter. */ - enum traceOptionsEnum optionIndex, /* Add, info or remove */ - Tcl_Size objc, /* Number of arguments. */ + enum traceOptionsEnum optionIndex, /* Add, info or remove */ + Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { const char *name, *command; @@ -720,8 +720,8 @@ TraceCommandObjCmd( static int TraceVariableObjCmd( Tcl_Interp *interp, /* Current interpreter. */ - enum traceOptionsEnum optionIndex, /* Add, info or remove */ - Tcl_Size objc, /* Number of arguments. */ + enum traceOptionsEnum optionIndex, /* Add, info or remove */ + Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { const char *name, *command; @@ -981,7 +981,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; @@ -1044,7 +1044,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; @@ -1149,7 +1149,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 @@ -1294,7 +1294,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; @@ -1400,7 +1400,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; @@ -1538,7 +1538,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. */ @@ -1833,7 +1833,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 @@ -2016,10 +2016,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 */ { @@ -2035,10 +2035,10 @@ Tcl_CreateObjTrace( 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 */ { @@ -2124,11 +2124,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)); @@ -2776,7 +2776,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; @@ -2979,7 +2979,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; diff --git a/generic/tclUtf.c b/generic/tclUtf.c index 2406ac2..36ff919 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -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; diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 4beb25d..ea3bba1 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -1051,7 +1051,7 @@ TclScanElement( Tcl_Size extra = 0; /* Count of number of extra bytes needed for * formatted element, assuming we use escape * sequences in formatting. */ - Tcl_Size bytesNeeded; /* Buffer length computed to complete the + Tcl_Size bytesNeeded; /* Buffer length computed to complete the * element formatting in the selected mode. */ #if COMPAT int preferEscape = 0; /* Use preferences to track whether to use */ @@ -1368,7 +1368,7 @@ Tcl_ConvertElement( Tcl_Size Tcl_ConvertCountedElement( - const char *src, /* Source information for list element. */ + const char *src, /* Source information for list element. */ Tcl_Size length, /* Number of bytes in src, or TCL_INDEX_NONE. */ char *dst, /* Place to put list-ified element. */ int flags) /* Flags produced by Tcl_ScanElement. */ @@ -1401,7 +1401,7 @@ Tcl_ConvertCountedElement( Tcl_Size TclConvertElement( - const char *src, /* Source information for list element. */ + const char *src, /* Source information for list element. */ Tcl_Size length, /* Number of bytes in src, or TCL_INDEX_NONE. */ char *dst, /* Place to put list-ified element. */ int flags) /* Flags produced by Tcl_ScanElement. */ @@ -1582,7 +1582,7 @@ TclConvertElement( char * Tcl_Merge( - Tcl_Size argc, /* How many strings to merge. */ + Tcl_Size argc, /* How many strings to merge. */ const char *const *argv) /* Array of string values. */ { #define LOCAL_SIZE 64 @@ -1659,14 +1659,14 @@ Tcl_Merge( Tcl_Size TclTrimRight( - const char *bytes, /* String to be trimmed... */ - Tcl_Size numBytes, /* ...and its length in bytes */ - /* Calls to TclUtfToUniChar() in this routine - * rely on (bytes[numBytes] == '\0'). */ - const char *trim, /* String of trim characters... */ - Tcl_Size numTrim) /* ...and its length in bytes */ - /* Calls to TclUtfToUniChar() in this routine - * rely on (trim[numTrim] == '\0'). */ + const char *bytes, /* String to be trimmed... */ + Tcl_Size numBytes, /* ...and its length in bytes */ + /* Calls to TclUtfToUniChar() in this routine + * rely on (bytes[numBytes] == '\0'). */ + const char *trim, /* String of trim characters... */ + Tcl_Size numTrim) /* ...and its length in bytes */ + /* Calls to TclUtfToUniChar() in this routine + * rely on (trim[numTrim] == '\0'). */ { const char *pp, *p = bytes + numBytes; int ch1, ch2; @@ -1738,14 +1738,14 @@ TclTrimRight( Tcl_Size TclTrimLeft( - const char *bytes, /* String to be trimmed... */ - Tcl_Size numBytes, /* ...and its length in bytes */ - /* Calls to TclUtfToUniChar() in this routine - * rely on (bytes[numBytes] == '\0'). */ - const char *trim, /* String of trim characters... */ - Tcl_Size numTrim) /* ...and its length in bytes */ - /* Calls to TclUtfToUniChar() in this routine - * rely on (trim[numTrim] == '\0'). */ + const char *bytes, /* String to be trimmed... */ + Tcl_Size numBytes, /* ...and its length in bytes */ + /* Calls to TclUtfToUniChar() in this routine + * rely on (bytes[numBytes] == '\0'). */ + const char *trim, /* String of trim characters... */ + Tcl_Size numTrim) /* ...and its length in bytes */ + /* Calls to TclUtfToUniChar() in this routine + * rely on (trim[numTrim] == '\0'). */ { const char *p = bytes; int ch1, ch2; @@ -1812,14 +1812,14 @@ TclTrimLeft( Tcl_Size TclTrim( - const char *bytes, /* String to be trimmed... */ - Tcl_Size numBytes, /* ...and its length in bytes */ - /* Calls in this routine - * rely on (bytes[numBytes] == '\0'). */ - const char *trim, /* String of trim characters... */ - Tcl_Size numTrim, /* ...and its length in bytes */ - /* Calls in this routine - * rely on (trim[numTrim] == '\0'). */ + const char *bytes, /* String to be trimmed... */ + Tcl_Size numBytes, /* ...and its length in bytes */ + /* Calls in this routine + * rely on (bytes[numBytes] == '\0'). */ + const char *trim, /* String of trim characters... */ + Tcl_Size numTrim, /* ...and its length in bytes */ + /* Calls in this routine + * rely on (trim[numTrim] == '\0'). */ Tcl_Size *trimRightPtr) /* Offset from the end of the string. */ { Tcl_Size trimLeft = 0, trimRight = 0; @@ -1874,7 +1874,7 @@ TclTrim( char * Tcl_Concat( - Tcl_Size argc, /* Number of strings to concatenate. */ + Tcl_Size argc, /* Number of strings to concatenate. */ const char *const *argv) /* Array of strings to concatenate. */ { Tcl_Size i, needSpace = 0, bytesNeeded = 0; @@ -2352,11 +2352,11 @@ Tcl_StringCaseMatch( int TclByteArrayMatch( const unsigned char *string,/* String. */ - Tcl_Size strLen, /* Length of String */ + Tcl_Size strLen, /* Length of String */ const unsigned char *pattern, /* Pattern, which may contain special * characters. */ - Tcl_Size ptnLen, /* Length of Pattern */ + Tcl_Size ptnLen, /* Length of Pattern */ TCL_UNUSED(int) /*flags*/) { const unsigned char *stringEnd, *patternEnd; @@ -2824,7 +2824,7 @@ Tcl_DStringAppendElement( void Tcl_DStringSetLength( Tcl_DString *dsPtr, /* Structure describing dynamic string. */ - Tcl_Size length) /* New length for dynamic string. */ + Tcl_Size length) /* New length for dynamic string. */ { Tcl_Size newsize; @@ -3313,7 +3313,7 @@ Tcl_Size TclFormatInt( char *buffer, /* Points to the storage into which the * formatted characters are written. */ - Tcl_WideInt n) /* The integer to format. */ + Tcl_WideInt n) /* The integer to format. */ { Tcl_WideUInt intVal; int i = 0, numFormatted, j; @@ -3375,14 +3375,14 @@ TclFormatInt( static int GetWideForIndex( - Tcl_Interp *interp, /* Interpreter to use for error reporting. If + Tcl_Interp *interp, /* Interpreter to use for error reporting. If * NULL, then no error message is left after * errors. */ - Tcl_Obj *objPtr, /* Points to the value to be parsed */ - Tcl_WideInt endValue, /* The value to be stored at *widePtr if + Tcl_Obj *objPtr, /* Points to the value to be parsed */ + Tcl_WideInt endValue, /* The value to be stored at *widePtr if * objPtr holds "end". * NOTE: this value may be TCL_INDEX_NONE. */ - Tcl_WideInt *widePtr) /* Location filled in with a wide integer + Tcl_WideInt *widePtr) /* Location filled in with a wide integer * representing an index. */ { int numType; @@ -3510,10 +3510,10 @@ Tcl_GetIntForIndex( static int GetEndOffsetFromObj( Tcl_Interp *interp, - Tcl_Obj *objPtr, /* Pointer to the object to parse */ - Tcl_WideInt endValue, /* The value to be stored at "widePtr" if + Tcl_Obj *objPtr, /* Pointer to the object to parse */ + Tcl_WideInt endValue, /* The value to be stored at "widePtr" if * "objPtr" holds "end". */ - Tcl_WideInt *widePtr) /* Location filled in with an integer + Tcl_WideInt *widePtr) /* Location filled in with an integer * representing an index. */ { Tcl_ObjInternalRep *irPtr; @@ -3809,11 +3809,11 @@ GetEndOffsetFromObj( int TclIndexEncode( - Tcl_Interp *interp, /* For error reporting, may be NULL */ - Tcl_Obj *objPtr, /* Index value to parse */ - int before, /* Value to return for index before beginning */ - int after, /* Value to return for index after end */ - int *indexPtr) /* Where to write the encoded answer, not NULL */ + Tcl_Interp *interp, /* For error reporting, may be NULL */ + Tcl_Obj *objPtr, /* Index value to parse */ + int before, /* Value to return for index before beginning */ + int after, /* Value to return for index after end */ + int *indexPtr) /* Where to write the encoded answer, not NULL */ { Tcl_WideInt wide; int idx; @@ -3896,7 +3896,7 @@ TclIndexEncode( idx = (int)wide; } } else { - /* objPtr is not purely numeric (end etc.) */ + /* objPtr is not purely numeric (end etc.) */ /* * On 64-bit systems, indices in the range end-LIST_MAX:end-INT_MAX @@ -3955,8 +3955,8 @@ rangeerror: Tcl_Size TclIndexDecode( - int encoded, /* Value to decode */ - Tcl_Size endValue) /* Meaning of "end" to use, > TCL_INDEX_END */ + int encoded, /* Value to decode */ + Tcl_Size endValue) /* Meaning of "end" to use, > TCL_INDEX_END */ { if (encoded > TCL_INDEX_END) { return encoded; @@ -3985,8 +3985,8 @@ TclIndexDecode( */ int TclCommandWordLimitError( - Tcl_Interp *interp, /* May be NULL */ - Tcl_Size count) /* If <= 0, "unknown" */ + Tcl_Interp *interp, /* May be NULL */ + Tcl_Size count) /* If <= 0, "unknown" */ { if (interp) { if (count > 0) { diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index b59a091..0e4f122 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -5634,7 +5634,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/macosx/tclMacOSXFCmd.c b/macosx/tclMacOSXFCmd.c index 16a728f..6cb5f8e 100644 --- a/macosx/tclMacOSXFCmd.c +++ b/macosx/tclMacOSXFCmd.c @@ -118,10 +118,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; diff --git a/macosx/tclMacOSXNotify.c b/macosx/tclMacOSXNotify.c index 3c3f923..aa527c7 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. @@ -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); diff --git a/unix/tclEpollNotfy.c b/unix/tclEpollNotfy.c index 8c392f0..db6ee13 100644 --- a/unix/tclEpollNotfy.c +++ b/unix/tclEpollNotfy.c @@ -42,7 +42,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- @@ -513,7 +513,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); @@ -791,7 +791,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/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..04c98b0 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)) { diff --git a/unix/tclSelectNotfy.c b/unix/tclSelectNotfy.c index bede898..1235801 100644 --- a/unix/tclSelectNotfy.c +++ b/unix/tclSelectNotfy.c @@ -32,7 +32,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; @@ -480,7 +480,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); diff --git a/unix/tclUnixChan.c b/unix/tclUnixChan.c index 75584fe..291a1c5 100644 --- a/unix/tclUnixChan.c +++ b/unix/tclUnixChan.c @@ -1779,22 +1779,16 @@ TclpOpenFileChannel( * Note: since paths starting with ~ are absolute, it also considers tilde expansion, * (proper error message of tests *io-40.17 "tilde substitution in open") */ - if ( - ( - ( - !TclFSCwdIsNative() && - (Tcl_FSGetPathType(pathPtr) != TCL_PATH_ABSOLUTE) - ) || - (*TclGetString(pathPtr) == '~') /* possible tilde expansion */ - ) && - Tcl_FSGetNormalizedPath(interp, pathPtr) == NULL - ) { + if (((!TclFSCwdIsNative() + && (Tcl_FSGetPathType(pathPtr) != TCL_PATH_ABSOLUTE)) + || (*TclGetString(pathPtr) == '~')) /* possible tilde expansion */ + && Tcl_FSGetNormalizedPath(interp, pathPtr) == NULL) { return NULL; } Tcl_AppendResult(interp, "couldn't open \"", - TclGetString(pathPtr), "\": filename is invalid on this platform", - (char *)NULL); + TclGetString(pathPtr), + "\": filename is invalid on this platform", (char *)NULL); } return NULL; } diff --git a/unix/tclUnixFCmd.c b/unix/tclUnixFCmd.c index db45999..09845c3 100644 --- a/unix/tclUnixFCmd.c +++ b/unix/tclUnixFCmd.c @@ -1432,10 +1432,10 @@ GetOwnerAttribute( static int GetPermissionsAttribute( - Tcl_Interp *interp, /* The interp we are using for errors. */ + Tcl_Interp *interp, /* The interp we are using for errors. */ TCL_UNUSED(int) /*objIndex*/, - Tcl_Obj *fileName, /* The name of the file (UTF-8). */ - Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */ + Tcl_Obj *fileName, /* The name of the file (UTF-8). */ + Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */ { Tcl_StatBuf statBuf; int result; @@ -1740,7 +1740,7 @@ TclpObjListVolumes(void) static int GetModeFromPermString( TCL_UNUSED(Tcl_Interp *), - const char *modeStringPtr, /* Permissions string */ + const char *modeStringPtr, /* Permissions string */ mode_t *modePtr) /* pointer to the mode value */ { mode_t newMode; @@ -1933,8 +1933,7 @@ TclpObjNormalizePath( * be 0 or the offset of a directory separator * at the end of a path part that is already * normalized. I.e. this is not the index of - * the byte just after the separator. */ - + * the byte just after the separator. */ { const char *currentPathEndPosition; char cur; @@ -2462,10 +2461,10 @@ GetUnixFileAttributes( static int SetUnixFileAttributes( - 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 *attributePtr) /* The attribute to set. */ + 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 *attributePtr) /* The attribute to set. */ { int yesNo, fileAttributes, old; WCHAR *winPath; diff --git a/unix/tclUnixFile.c b/unix/tclUnixFile.c index 2b0b5b0..668ec7c 100644 --- a/unix/tclUnixFile.c +++ b/unix/tclUnixFile.c @@ -431,10 +431,10 @@ TclpMatchInDirectory( static int NativeMatchType( - Tcl_Interp *interp, /* Interpreter to receive errors. */ - const char *nativeEntry, /* Native path to check. */ - const char *nativeName, /* Native filename to check. */ - Tcl_GlobTypeData *types) /* Type description to match against. */ + Tcl_Interp *interp, /* Interpreter to receive errors. */ + const char *nativeEntry, /* Native path to check. */ + const char *nativeName, /* Native filename to check. */ + Tcl_GlobTypeData *types) /* Type description to match against. */ { Tcl_StatBuf buf; diff --git a/unix/tclUnixInit.c b/unix/tclUnixInit.c index f276e71..00b525e 100644 --- a/unix/tclUnixInit.c +++ b/unix/tclUnixInit.c @@ -572,7 +572,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) { diff --git a/unix/tclUnixPipe.c b/unix/tclUnixPipe.c index 8d4a6b0..9a032ee 100644 --- a/unix/tclUnixPipe.c +++ b/unix/tclUnixPipe.c @@ -1003,7 +1003,7 @@ TclGetAndDetachPids( static int PipeBlockModeProc( - void *instanceData, /* Pipe state. */ + void *instanceData, /* Pipe state. */ int mode) /* The mode to set. Can be one of * TCL_MODE_BLOCKING or * TCL_MODE_NONBLOCKING. */ @@ -1043,7 +1043,7 @@ PipeBlockModeProc( static int PipeClose2Proc( - void *instanceData, /* The pipe to close. */ + void *instanceData, /* The pipe to close. */ Tcl_Interp *interp, /* For error reporting. */ int flags) /* Flags that indicate which side to close. */ { @@ -1140,7 +1140,7 @@ PipeClose2Proc( static int PipeInputProc( - void *instanceData, /* Pipe state. */ + void *instanceData, /* Pipe state. */ char *buf, /* Where to store data read. */ int toRead, /* How much space is available in the * buffer? */ @@ -1191,7 +1191,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 *errorCodePtr) /* Where to store error code. */ @@ -1252,7 +1252,7 @@ PipeWatchNotifyChannelWrapper( static void PipeWatchProc( - void *instanceData, /* The pipe state. */ + void *instanceData, /* The pipe state. */ int mask) /* Events of interest; an OR-ed combination of * TCL_READABLE, TCL_WRITABLE and * TCL_EXCEPTION. */ @@ -1300,9 +1300,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. */ { PipeState *psPtr = (PipeState *)instanceData; diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c index f2b15b2..142ecc7 100644 --- a/unix/tclUnixSock.c +++ b/unix/tclUnixSock.c @@ -64,7 +64,7 @@ struct TcpState { */ Tcl_TcpAcceptProc *acceptProc; /* Proc to call on accept. */ - void *acceptProcData; /* The data for the accept proc. */ + void *acceptProcData; /* The data for the accept proc. */ /* * Only needed for client sockets @@ -74,10 +74,10 @@ struct TcpState { struct addrinfo *addr; /* Iterator over addrlist. */ struct addrinfo *myaddrlist;/* Local address. */ struct addrinfo *myaddr; /* Iterator over myaddrlist. */ - int filehandlers; /* Caches FileHandlers that get set up while - * an async socket is not yet connected. */ - int connectError; /* Cache SO_ERROR of async socket. */ - int cachedBlocking; /* Cache blocking mode of async socket. */ + int filehandlers; /* Caches FileHandlers that get set up while + * an async socket is not yet connected. */ + int connectError; /* Cache SO_ERROR of async socket. */ + int cachedBlocking; /* Cache blocking mode of async socket. */ }; /* @@ -356,7 +356,7 @@ TclpFinalizeSockets(void) static int TcpBlockModeProc( - void *instanceData, /* Socket state. */ + void *instanceData, /* Socket state. */ int mode) /* The mode to set. Can be one of * TCL_MODE_BLOCKING or * TCL_MODE_NONBLOCKING. */ @@ -501,7 +501,7 @@ WaitForConnect( static int TcpInputProc( - void *instanceData, /* Socket state. */ + void *instanceData, /* Socket state. */ char *buf, /* Where to store data read. */ int bufSize, /* How much space is available in the * buffer? */ @@ -552,7 +552,7 @@ TcpInputProc( static int TcpOutputProc( - void *instanceData, /* Socket state. */ + void *instanceData, /* Socket state. */ const char *buf, /* The data buffer. */ int toWrite, /* How many bytes to write? */ int *errorCodePtr) /* Where to store error code. */ @@ -593,7 +593,7 @@ TcpOutputProc( static int TcpCloseProc( - void *instanceData, /* The socket to close. */ + void *instanceData, /* The socket to close. */ TCL_UNUSED(Tcl_Interp *)) { TcpState *statePtr = (TcpState *)instanceData; @@ -654,7 +654,7 @@ TcpCloseProc( static int TcpClose2Proc( - void *instanceData, /* The socket to close. */ + void *instanceData, /* The socket to close. */ TCL_UNUSED(Tcl_Interp *), int flags) /* Flags that indicate which side to close. */ { @@ -1168,7 +1168,7 @@ WrapNotify( static void TcpWatchProc( - void *instanceData, /* The socket state. */ + void *instanceData, /* The socket state. */ int mask) /* Events of interest; an OR-ed combination of * TCL_READABLE, TCL_WRITABLE and * TCL_EXCEPTION. */ @@ -1241,9 +1241,9 @@ TcpWatchProc( static int TcpGetHandleProc( - void *instanceData, /* The socket state. */ + void *instanceData, /* The socket state. */ TCL_UNUSED(int) /*direction*/, - void **handlePtr) /* Where to store the handle. */ + void **handlePtr) /* Where to store the handle. */ { TcpState *statePtr = (TcpState *)instanceData; @@ -1265,7 +1265,7 @@ TcpGetHandleProc( static void TcpAsyncCallback( - void *clientData, /* The socket state. */ + void *clientData, /* The socket state. */ TCL_UNUSED(int) /*mask*/) { TcpConnect(NULL, (TcpState *)clientData); @@ -1573,7 +1573,7 @@ Tcl_OpenTcpClient( Tcl_Channel Tcl_MakeTcpClientChannel( - void *sock) /* The socket to wrap up into a channel. */ + void *sock) /* The socket to wrap up into a channel. */ { return (Tcl_Channel) TclpMakeTcpClientChannelMode(sock, TCL_READABLE | TCL_WRITABLE); @@ -1598,7 +1598,7 @@ Tcl_MakeTcpClientChannel( void * TclpMakeTcpClientChannelMode( - void *sock, /* The socket to wrap up into a channel. */ + void *sock, /* The socket to wrap up into a channel. */ int mode) /* OR'ed combination of TCL_READABLE and * TCL_WRITABLE to indicate file mode. */ { @@ -1645,7 +1645,7 @@ Tcl_OpenTcpServerEx( const char *service, /* Port number to open. */ const char *myHost, /* Name of local host. */ unsigned int flags, /* Flags. */ - int backlog, /* Length of OS listen backlog queue. */ + int backlog, /* Length of OS listen backlog queue. */ Tcl_TcpAcceptProc *acceptProc, /* Callback for accepting connections from new * clients. */ @@ -1899,7 +1899,7 @@ Tcl_OpenTcpServerEx( static void TcpAccept( - void *data, /* Callback token. */ + void *data, /* Callback token. */ TCL_UNUSED(int) /*mask*/) { TcpFdList *fds = (TcpFdList *)data; /* Client data of server socket. */ diff --git a/unix/tclUnixTest.c b/unix/tclUnixTest.c index 4d95309..31c92a9 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. */ { 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..e5bcb07 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; @@ -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; diff --git a/win/tclWinChan.c b/win/tclWinChan.c index 393b48c..5dad26a 100644 --- a/win/tclWinChan.c +++ b/win/tclWinChan.c @@ -385,7 +385,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 +424,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 +502,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 +554,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 +630,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 +685,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 +732,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 +771,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; @@ -906,7 +906,7 @@ 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. */ @@ -1004,13 +1004,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 +1217,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..a077954 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; @@ -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; diff --git a/win/tclWinDde.c b/win/tclWinDde.c index 0a4cb3f..49d2803 100644 --- a/win/tclWinDde.c +++ b/win/tclWinDde.c @@ -273,10 +273,10 @@ Initialize(void) static const WCHAR * DdeSetServerName( Tcl_Interp *interp, - const WCHAR *name, /* The name that will be used to refer to the + const WCHAR *name, /* The name that will be used to refer to the * interpreter in later "send" commands. Must * be globally unique. */ - int flags, /* DDE_FLAG_FORCE or 0 */ + int flags, /* DDE_FLAG_FORCE or 0 */ Tcl_Obj *handlerPtr) /* Name of the optional proc/command to handle * incoming Dde eval's */ { @@ -478,7 +478,7 @@ DdeGetRegistrationPtr( static void DeleteProc( - void *clientData) /* The interp we are deleting. */ + void *clientData) /* The interp we are deleting. */ { RegisteredInterp *riPtr = (RegisteredInterp *) clientData; RegisteredInterp *searchPtr, *prevPtr; @@ -531,8 +531,8 @@ DeleteProc( static Tcl_Obj * ExecuteRemoteObject( - RegisteredInterp *riPtr, /* Info about this server. */ - Tcl_Obj *ddeObjectPtr) /* The object to execute. */ + RegisteredInterp *riPtr, /* Info about this server. */ + Tcl_Obj *ddeObjectPtr) /* The object to execute. */ { Tcl_Obj *returnPackagePtr; int result = TCL_OK; @@ -1219,7 +1219,7 @@ DdeGetServicesList( static void SetDdeError( - Tcl_Interp *interp) /* The interp to put the message in. */ + Tcl_Interp *interp) /* The interp to put the message in. */ { const char *errorMessage, *errorCode; @@ -1266,9 +1266,9 @@ SetDdeError( static int DdeObjCmd( - void *dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* The interp we are sending from */ - Tcl_Size objc, /* Number of arguments */ + Tcl_Size objc, /* Number of arguments */ Tcl_Obj *const *objv) /* The arguments */ { static const char *const ddeCommands[] = { diff --git a/win/tclWinFCmd.c b/win/tclWinFCmd.c index b878cd4..694be0d 100644 --- a/win/tclWinFCmd.c +++ b/win/tclWinFCmd.c @@ -17,7 +17,7 @@ * TraverseWinTree() calls the traverseProc() */ -#define DOTREE_PRED 1 /* pre-order directory */ +#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 */ @@ -1121,7 +1121,6 @@ DoRemoveJustDirectory( } } return TCL_ERROR; - } static int diff --git a/win/tclWinFile.c b/win/tclWinFile.c index 6c614b1..212ec52 100644 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -2518,9 +2518,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 nextCheckpoint) /* offset to start at in pathPtr */ { char *lastValidPathEnd = NULL; Tcl_DString dsNorm; /* This will hold the normalized string. */ diff --git a/win/tclWinInit.c b/win/tclWinInit.c index 141aff1..9ea1442 100644 --- a/win/tclWinInit.c +++ b/win/tclWinInit.c @@ -577,7 +577,7 @@ Tcl_Size TclpFindVariable( const char *name, /* Name of desired environment variable * (UTF-8). */ - Tcl_Size *lengthPtr) /* Used to return length of name (for + Tcl_Size *lengthPtr) /* Used to return length of name (for * successful searches) or number of non-NULL * entries in environ (for unsuccessful * searches). */ diff --git a/win/tclWinNotify.c b/win/tclWinNotify.c index 2c93a41..853ad9e 100644 --- a/win/tclWinNotify.c +++ b/win/tclWinNotify.c @@ -148,7 +148,7 @@ TclpInitNotifier(void) void TclpFinalizeNotifier( - void *clientData) /* Pointer to notifier data. */ + void *clientData) /* Pointer to notifier data. */ { ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData; @@ -218,7 +218,7 @@ TclpFinalizeNotifier( void TclpAlertNotifier( - void *clientData) /* Pointer to thread data. */ + void *clientData) /* Pointer to thread data. */ { ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData; diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c index 2942ea1..dec7f13 100644 --- a/win/tclWinPipe.c +++ b/win/tclWinPipe.c @@ -133,7 +133,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 @@ -1969,7 +1969,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. */ { @@ -2008,7 +2008,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. */ { @@ -2179,7 +2179,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? */ @@ -2273,7 +2273,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. */ @@ -2347,7 +2347,6 @@ PipeOutputProc( error: *errorCode = errno; return -1; - } /* @@ -2455,7 +2454,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. */ @@ -2517,9 +2516,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; @@ -2943,7 +2942,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; @@ -3066,7 +3065,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; diff --git a/win/tclWinReg.c b/win/tclWinReg.c index f20833a..e29556c 100644 --- a/win/tclWinReg.c +++ b/win/tclWinReg.c @@ -256,9 +256,9 @@ DeleteCmd( static int RegistryObjCmd( - void *dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ - Tcl_Size objc, /* Number of arguments. */ + Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument values. */ { Tcl_Size n = 1, argc; @@ -1376,7 +1376,7 @@ SetValue( static int BroadcastValue( Tcl_Interp *interp, /* Current interpreter. */ - Tcl_Size objc, /* Number of arguments. */ + Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument values. */ { LRESULT result; -- cgit v0.12 From af9dc0bf29bbdbdec72067e2dbadf232a49257d9 Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 3 Mar 2025 09:33:42 +0000 Subject: Mostly whitespace fixes, but also a bug in Tcl_SetWideUIntObj --- generic/tclAsync.c | 8 ++++---- generic/tclClock.c | 10 +++++----- generic/tclCmdIL.c | 25 ++++++++++-------------- generic/tclCompCmds.c | 2 +- generic/tclCompile.c | 2 +- generic/tclDictObj.c | 2 +- generic/tclEncoding.c | 2 +- generic/tclExecute.c | 2 +- generic/tclHash.c | 6 ++---- generic/tclIO.c | 14 +++++++------- generic/tclLiteral.c | 10 ++++------ generic/tclNotify.c | 4 ++-- generic/tclObj.c | 45 ++++++++++++++++++++------------------------ generic/tclParse.c | 9 +++------ generic/tclTest.c | 16 ++++++++-------- generic/tclTestObj.c | 18 +++++++++--------- generic/tclTestProcBodyObj.c | 2 +- generic/tclThreadAlloc.c | 2 +- generic/tclTimer.c | 2 +- generic/tclUtil.c | 6 +++--- generic/tclZipfs.c | 3 +-- macosx/tclMacOSXFCmd.c | 10 +++++----- macosx/tclMacOSXNotify.c | 4 ++-- unix/tclSelectNotfy.c | 2 +- unix/tclUnixCompat.c | 4 ++-- unix/tclUnixFile.c | 2 +- unix/tclUnixPipe.c | 2 +- unix/tclUnixTest.c | 4 ++-- unix/tclXtNotify.c | 4 ++-- win/tclWin32Dll.c | 4 ++-- win/tclWinNotify.c | 4 ++-- win/tclWinPipe.c | 4 ++-- win/tclWinTest.c | 6 +++--- 33 files changed, 111 insertions(+), 129 deletions(-) diff --git a/generic/tclAsync.c b/generic/tclAsync.c index dfed6ec..7a5b862 100644 --- a/generic/tclAsync.c +++ b/generic/tclAsync.c @@ -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; @@ -223,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; @@ -377,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/tclClock.c b/generic/tclClock.c index 0c37e6a..c3b87d8 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -4583,11 +4583,11 @@ ClockSafeCatchCmd( Tcl_Obj *const objv[]) { typedef struct { - int status; /* return code status */ - int flags; /* Each remaining field saves the */ - int returnLevel; /* corresponding field of the Interp */ - int returnCode; /* struct. These fields taken together are */ - Tcl_Obj *errorInfo; /* the "state" of the interp. */ + int status; /* return code status */ + int flags; /* Each remaining field saves the */ + int returnLevel; /* corresponding field of the Interp */ + int returnCode; /* struct. These fields taken together are */ + Tcl_Obj *errorInfo; /* the "state" of the interp. */ Tcl_Obj *errorCode; Tcl_Obj *returnOpts; Tcl_Obj *objResult; diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index a46f6d9..429daec 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -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; /* @@ -2427,7 +2427,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 +2520,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 +2556,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 +2604,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 +2722,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; @@ -2937,9 +2933,8 @@ 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; @@ -5361,7 +5356,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/tclCompCmds.c b/generic/tclCompCmds.c index 28e4247..0d80f5b 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -3346,7 +3346,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 == '%') { diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 881c356..659d4fd 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -2639,7 +2639,7 @@ TclCompileCmdWord( Tcl_Interp *interp, /* Used for error and status reporting. */ Tcl_Token *tokenPtr, /* Pointer to first in an array of tokens for * a command word to compile inline. */ - size_t count1, /* Number of tokens to consider at tokenPtr. + size_t count1, /* Number of tokens to consider at tokenPtr. * Must be at least 1. */ CompileEnv *envPtr) /* Holds the resulting instructions. */ { diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index b1249e8..9c1734b 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -1265,7 +1265,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; diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 5842a0b..0f7a6c5 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -3057,7 +3057,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/tclExecute.c b/generic/tclExecute.c index 473e226..fced7d0 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -9560,7 +9560,7 @@ TclExprFloatError( int TclLog2( - int value) /* The integer for which to compute the log + int value) /* The integer for which to compute the log * base 2. */ { int n = value; diff --git a/generic/tclHash.c b/generic/tclHash.c index 9bdb079..e093107 100644 --- a/generic/tclHash.c +++ b/generic/tclHash.c @@ -104,8 +104,7 @@ const Tcl_HashKeyType tclStringHashKeyType = { void Tcl_InitHashTable( - Tcl_HashTable *tablePtr, - /* Pointer to table record, which is supplied + Tcl_HashTable *tablePtr, /* Pointer to table record, which is supplied * by the caller. */ int keyType) /* Type of keys to use in table: * TCL_STRING_KEYS, TCL_ONE_WORD_KEYS, or an @@ -142,8 +141,7 @@ Tcl_InitHashTable( void Tcl_InitCustomHashTable( - Tcl_HashTable *tablePtr, - /* Pointer to table record, which is supplied + Tcl_HashTable *tablePtr, /* Pointer to table record, which is supplied * by the caller. */ int keyType, /* Type of keys to use in table: * TCL_STRING_KEYS, TCL_ONE_WORD_KEYS, diff --git a/generic/tclIO.c b/generic/tclIO.c index 77b9475..240fbbe 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -336,27 +336,27 @@ static void FreeChannelInternalRep(Tcl_Obj *objPtr); static const Tcl_ObjType chanObjType = { "channel", /* name for this type */ - FreeChannelInternalRep, /* freeIntRepProc */ - DupChannelInternalRep, /* dupIntRepProc */ + FreeChannelInternalRep, /* freeIntRepProc */ + DupChannelInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ NULL, /* setFromAnyProc */ TCL_OBJTYPE_V0 }; -#define ChanSetInternalRep(objPtr, resPtr) \ +#define ChanSetInternalRep(objPtr, resPtr) \ do { \ Tcl_ObjInternalRep ir; \ (resPtr)->refCount++; \ ir.twoPtrValue.ptr1 = (resPtr); \ ir.twoPtrValue.ptr2 = NULL; \ - Tcl_StoreInternalRep((objPtr), &chanObjType, &ir); \ + Tcl_StoreInternalRep((objPtr), &chanObjType, &ir); \ } while (0) -#define ChanGetInternalRep(objPtr, resPtr) \ +#define ChanGetInternalRep(objPtr, resPtr) \ do { \ - const Tcl_ObjInternalRep *irPtr; \ + const Tcl_ObjInternalRep *irPtr; \ irPtr = TclFetchInternalRep((objPtr), &chanObjType); \ - (resPtr) = irPtr ? (ResolvedChanName *)irPtr->twoPtrValue.ptr1 : NULL; \ + (resPtr) = irPtr ? (ResolvedChanName *)irPtr->twoPtrValue.ptr1 : NULL; \ } while (0) #define BUSY_STATE(st, fl) \ diff --git a/generic/tclLiteral.c b/generic/tclLiteral.c index 83323ba..30b8c3b 100644 --- a/generic/tclLiteral.c +++ b/generic/tclLiteral.c @@ -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) @@ -911,8 +910,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. */ + size_t length) /* Number of bytes in the string. */ { size_t result = 0; @@ -975,8 +974,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/tclNotify.c b/generic/tclNotify.c index 8d92f1f..628beb7 100644 --- a/generic/tclNotify.c +++ b/generic/tclNotify.c @@ -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); diff --git a/generic/tclObj.c b/generic/tclObj.c index 7e6e4b2..fdefcb3 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -1034,9 +1034,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 +1162,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; @@ -2353,7 +2353,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 @@ -2852,8 +2852,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; @@ -2898,8 +2897,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. */ @@ -2917,8 +2915,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*/) @@ -2947,9 +2944,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)) { @@ -2979,9 +2975,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)) { @@ -2994,7 +2989,7 @@ Tcl_SetWideUIntObj( Tcl_Panic("%s: memory overflow", "Tcl_SetWideUIntObj"); } TclSetBignumInternalRep(objPtr, &bignumValue); - } { + } else { TclSetIntObj(objPtr, (Tcl_WideInt)uwideValue); } } @@ -3934,7 +3929,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. */ @@ -4007,7 +4002,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. */ @@ -4084,16 +4079,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) { @@ -4161,8 +4157,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, diff --git a/generic/tclParse.c b/generic/tclParse.c index dca351c..3879733 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -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. */ { @@ -1619,8 +1618,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 @@ -1820,8 +1818,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 diff --git a/generic/tclTest.c b/generic/tclTest.c index 660bf53..be31501 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -836,9 +836,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; @@ -1590,7 +1590,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"); @@ -2995,7 +2995,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"); @@ -4641,8 +4641,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 */ { @@ -5885,7 +5885,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) { diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index c7a9704..b8da2f7 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -1082,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 }; @@ -1493,7 +1493,7 @@ TeststringobjCmd( } Tcl_SetWideIntObj(Tcl_GetObjResult(interp), length); break; - case 10: { /* range */ + case 10: { /* range */ Tcl_Size first, last; if (objc != 5) { goto wrongNumArgs; @@ -1567,7 +1567,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; 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/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/tclTimer.c b/generic/tclTimer.c index 42221f0..bd0664e 100644 --- a/generic/tclTimer.c +++ b/generic/tclTimer.c @@ -1214,7 +1214,7 @@ AfterProc( static void FreeAfterPtr( - AfterInfo *afterPtr) /* Command to be deleted. */ + AfterInfo *afterPtr) /* Command to be deleted. */ { AfterInfo *prevPtr; AfterAssocData *assocPtr = afterPtr->assocPtr; diff --git a/generic/tclUtil.c b/generic/tclUtil.c index ea3bba1..c28056d 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -1338,9 +1338,9 @@ TclScanElement( Tcl_Size Tcl_ConvertElement( - const char *src, /* Source information for list element. */ - char *dst, /* Place to put list-ified element. */ - int flags) /* Flags produced by Tcl_ScanElement. */ + const char *src, /* Source information for list element. */ + char *dst, /* Place to put list-ified element. */ + int flags) /* Flags produced by Tcl_ScanElement. */ { return Tcl_ConvertCountedElement(src, TCL_INDEX_NONE, dst, flags); } diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index 0e4f122..d946372 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -3883,8 +3883,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 diff --git a/macosx/tclMacOSXFCmd.c b/macosx/tclMacOSXFCmd.c index 6cb5f8e..e26dca2 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 }; diff --git a/macosx/tclMacOSXNotify.c b/macosx/tclMacOSXNotify.c index aa527c7..d096b35 100644 --- a/macosx/tclMacOSXNotify.c +++ b/macosx/tclMacOSXNotify.c @@ -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; @@ -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/unix/tclSelectNotfy.c b/unix/tclSelectNotfy.c index 1235801..1f77cc2 100644 --- a/unix/tclSelectNotfy.c +++ b/unix/tclSelectNotfy.c @@ -643,7 +643,7 @@ NotifierProc( int TclpWaitForEvent( - const Tcl_Time *timePtr) /* Maximum block time, or NULL. */ + const Tcl_Time *timePtr) /* Maximum block time, or NULL. */ { FileHandler *filePtr; int mask; diff --git a/unix/tclUnixCompat.c b/unix/tclUnixCompat.c index def69fa..e9af3fc 100644 --- a/unix/tclUnixCompat.c +++ b/unix/tclUnixCompat.c @@ -986,8 +986,8 @@ CopyString( 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/unix/tclUnixFile.c b/unix/tclUnixFile.c index 668ec7c..b6e1147 100644 --- a/unix/tclUnixFile.c +++ b/unix/tclUnixFile.c @@ -317,7 +317,7 @@ TclpMatchInDirectory( return TCL_OK; } - d = TclOSopendir(native); /* INTL: Native. */ + d = TclOSopendir(native); /* INTL: Native. */ if (d == NULL) { Tcl_DStringFree(&ds); if (interp != NULL) { diff --git a/unix/tclUnixPipe.c b/unix/tclUnixPipe.c index 9a032ee..f1ea101 100644 --- a/unix/tclUnixPipe.c +++ b/unix/tclUnixPipe.c @@ -401,7 +401,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 in UTF-8. * argv[0] contains the name of the executable * translated using Tcl_TranslateFileName diff --git a/unix/tclUnixTest.c b/unix/tclUnixTest.c index 31c92a9..75fad34 100644 --- a/unix/tclUnixTest.c +++ b/unix/tclUnixTest.c @@ -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; diff --git a/unix/tclXtNotify.c b/unix/tclXtNotify.c index e5bcb07..6d4e3c9 100644 --- a/unix/tclXtNotify.c +++ b/unix/tclXtNotify.c @@ -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; @@ -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/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/tclWinNotify.c b/win/tclWinNotify.c index 853ad9e..867e585 100644 --- a/win/tclWinNotify.c +++ b/win/tclWinNotify.c @@ -264,7 +264,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 +464,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 dec7f13..1474567 100644 --- a/win/tclWinPipe.c +++ b/win/tclWinPipe.c @@ -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 @@ -1552,7 +1552,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). */ diff --git a/win/tclWinTest.c b/win/tclWinTest.c index 8832235..9e2fdca 100644 --- a/win/tclWinTest.c +++ b/win/tclWinTest.c @@ -336,9 +336,9 @@ TestwinsleepCmd( static int TestExceptionCmd( TCL_UNUSED(void *), - Tcl_Interp* interp, /* Tcl interpreter */ - int objc, /* Argument count */ - Tcl_Obj *const objv[]) /* Argument vector */ + Tcl_Interp* interp, /* Tcl interpreter */ + int objc, /* Argument count */ + Tcl_Obj *const objv[]) /* Argument vector */ { static const char *const cmds[] = { "access_violation", "datatype_misalignment", "array_bounds", -- cgit v0.12 From b4c1dc69ebc521e3c7c8e695d8e7386591537308 Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 3 Mar 2025 09:40:44 +0000 Subject: Fix bug in Tcl_SetWideUIntObj. --- generic/tclObj.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclObj.c b/generic/tclObj.c index aa770c8..92c2731 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -3334,7 +3334,7 @@ Tcl_SetWideUIntObj( Tcl_Panic("%s: memory overflow", "Tcl_SetWideUIntObj"); } TclSetBignumInternalRep(objPtr, &bignumValue); - } { + } else { TclSetIntObj(objPtr, (Tcl_WideInt)uwideValue); } } -- cgit v0.12 From 5ba44669e05a90a4caaecdf38305094a1e568e7c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 3 Mar 2025 17:52:49 +0000 Subject: Update to appleboy/ssh-action@v1.2.1 --- .github/workflows/onefiledist.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/onefiledist.yml b/.github/workflows/onefiledist.yml index a914932..74b88bf 100644 --- a/.github/workflows/onefiledist.yml +++ b/.github/workflows/onefiledist.yml @@ -219,7 +219,7 @@ jobs: # MUST be a literal passwordless key - name: Publish files # https://github.com/marketplace/actions/ssh-remote-commands - uses: appleboy/ssh-action@v1.2.0 + uses: appleboy/ssh-action@v1.2.1 id: ssh if: steps.rsync.outcome == 'success' with: -- cgit v0.12 From ccc9b5906b4fa83a94691e1a0b59a357ed8368ff Mon Sep 17 00:00:00 2001 From: sebres Date: Tue, 4 Mar 2025 15:45:23 +0000 Subject: tests/clock.test: added test illustrating bug [2c0f49e26c27847a] - cache becomes inconsist when deriving localized formats (e. g. %x) --- tests/clock.test | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/tests/clock.test b/tests/clock.test index c710f0e..0dfb5f3 100644 --- a/tests/clock.test +++ b/tests/clock.test @@ -35521,6 +35521,18 @@ test clock-29.1812 {parsing of several localized formats} { } set res } [lrepeat 12 0] + +test clock-29.1813 {cache consistency when deriving localized formats, bug [2c0f49e26c27847a]} { + # ensure localized formats are not affected by mistaken merge of mc + # from parent locale, so such formats got invalidated in child cache: + namespace inscope ::tcl::clock { + ::msgcat::mcset en_US_roman_xx DATE_FORMAT "%d.%m.%Y" + ::msgcat::mcset en_US_roman_xx_yy DATE_FORMAT "%Y|%m|%d" + } + list [clock format 86400 -format %x -gmt 1 -locale en_US_roman] \ + [clock format 86400 -format %x -gmt 1 -locale en_US_roman_xx] \ + [clock format 86400 -format %x -gmt 1 -locale en_US_roman_xx_yy] +} {01/02/1970 02.01.1970 1970|01|02} # END testcases29 -- cgit v0.12 From 77b914e2ca91ab87d6613367164358bb16020c77 Mon Sep 17 00:00:00 2001 From: sebres Date: Tue, 4 Mar 2025 15:47:43 +0000 Subject: clock.tcl: fixes [2c0f49e26c27847a] - ensure cache remain consistent when deriving from parent (don't merge cached localized formats from parent locale) --- library/clock.tcl | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/library/clock.tcl b/library/clock.tcl index 84de2f1..ae33268 100644 --- a/library/clock.tcl +++ b/library/clock.tcl @@ -570,6 +570,12 @@ proc ::tcl::clock::mcMerge {locales} { if {[dict exists $Msgs $ns $loc]} { set mrgcat [dict merge $mrgcat [dict get $Msgs $ns $loc]] dict set mrgcat L $loc + # remove any previously localized formats (merged from parent + # locale and possibly cached in parent-mc by ClockLocalizeFormat), + # because they may depend on values which may vary in derivate: + foreach k [dict keys $mrgcat] { + if {[string match FMT_* $k]} { dict unset mrgcat $k } + } } else { # be sure a duplicate is created, don't overwrite {} (common) locale: set mrgcat [dict merge $mrgcat [dict create L $loc]] -- cgit v0.12 From 0735721a7bae7ff75a9bc49ae94ccf3cd87b556f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 4 Mar 2025 16:27:05 +0000 Subject: Update changes.md --- changes.md | 7 ++++++- generic/tclCmdMZ.c | 2 +- tests/exec.test | 6 +++--- 3 files changed, 10 insertions(+), 5 deletions(-) diff --git a/changes.md b/changes.md index 18f4a0a..5a29559 100644 --- a/changes.md +++ b/changes.md @@ -14,12 +14,17 @@ to the userbase. - [$interp eval $lambda] after [eval $lambda] or vice versa fails](https://core.tcl-lang.org/tcl/tktview/98006f) - [tcl::mathfunc::isunordered inconsistency with some integer values](https://core.tcl-lang.org/tcl/tktview/67d5f7) - [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) # Incompatibilities - No known incompatibilities with the Tcl 9.0.0 public interface. # Updated bundled packages, libraries, standards, data - - sqlite3 3.48.0 + - sqlite3 3.49.1 - tzdata 2025a Release Tcl 9.0.1 arises from the check-in with tag `core-9-0-1`. diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 8b59e34..fb04232 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -4507,7 +4507,7 @@ 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. */ diff --git a/tests/exec.test b/tests/exec.test index 706f80e..687ac6f 100644 --- a/tests/exec.test +++ b/tests/exec.test @@ -752,9 +752,9 @@ test exec-bug-4f0b5767ac {exec App Execution Alias} -constraints haveWinget -bod } -result "Windows Package Manager*" -match glob foreach cmdBuiltin { - assoc call cd cls color copy date del dir echo - erase exit ftype for if md mkdir mklink move path - pause prompt rd ren rename rmdir set start time + assoc call cd cls color copy date del dir echo + erase exit ftype for if md mkdir mklink move path + pause prompt rd ren rename rmdir set start time title type ver vol } { test auto_execok-$cmdBuiltin-1.0 "auto_execok $cmdBuiltin" \ -- cgit v0.12 From cab2cccea8e27a73250f3d8653f35e28d23d37db Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 4 Mar 2025 20:46:16 +0000 Subject: [e23e40222e] Revise HashString() to expect a Tcl_Size length argument --- generic/tclLiteral.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclLiteral.c b/generic/tclLiteral.c index 30b8c3b..38508ec 100644 --- a/generic/tclLiteral.c +++ b/generic/tclLiteral.c @@ -31,7 +31,7 @@ static size_t AddLocalLiteralEntry(CompileEnv *envPtr, Tcl_Obj *objPtr, int 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); @@ -911,7 +911,7 @@ TclReleaseLiteral( static size_t HashString( const char *string, /* String for which to compute hash value. */ - size_t length) /* Number of bytes in the string. */ + Tcl_Size length) /* Number of bytes in the string. */ { size_t result = 0; -- cgit v0.12 From 1d92ed1fd2c8bfd0cdc538b15fd3c217ac75f35c Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Wed, 5 Mar 2025 05:43:25 +0000 Subject: Possible fix for another BUFFER_PADDING panic --- generic/tclIO.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 240fbbe..eaa3cee 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -6063,7 +6063,8 @@ DoReadChars( } if (copiedNow < 0) { - if (GotFlag(statePtr, CHANNEL_EOF)) { + if (GotFlag(statePtr, CHANNEL_EOF) || + GotFlag(statePtr, CHANNEL_ENCODING_ERROR)) { break; } if ((GotFlag(statePtr, CHANNEL_NONBLOCKING) || allowShortReads) -- cgit v0.12 From edf06331d0f337a0cecfc3b91147ac40af670fcd Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Wed, 5 Mar 2025 06:41:43 +0000 Subject: Test cases --- tests/io.test | 51 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 51 insertions(+) diff --git a/tests/io.test b/tests/io.test index 475c05f..88986a7 100644 --- a/tests/io.test +++ b/tests/io.test @@ -9950,6 +9950,57 @@ test io-77.2 {open pipe encoding mismatch - use replace profile} -setup { read $fd } -result a\uFFFDb +test bug-73bb42fb-1 { + Non-blocking+buffer size+encoding error panic - TCL bug 73bb42fb +} -setup { + writeFile $path(test1) binary \xD6[string repeat _ 20] +} -body { + set fd [open $path(test1)] + fconfigure $fd -blocking 0 -buffersize 10 -translation lf -eofchar {} + list [catch {read $fd 1} e d] [dict get $d -code] [dict get $d -errorcode] [tell $fd] +} -cleanup { + close $fd +} -result {1 1 {POSIX EILSEQ {invalid or incomplete multibyte or wide character}} 0} + +test bug-73bb42fb-2 { + Non-blocking+buffer size+encoding error panic - TCL bug 73bb42fb +} -setup { + writeFile $path(test1) binary X\xD6[string repeat _ 20] +} -body { + # Verify single char read does not fail + set fd [open $path(test1)] + fconfigure $fd -blocking 0 -buffersize 10 -translation lf -eofchar {} + read $fd 1 +} -cleanup { + close $fd +} -result X + +test bug-73bb43fb-3 { + Non-blocking+buffer size+encoding error panic - TCL bug 73bb42fb +} -setup { + writeFile $path(test1) binary X\xD6[string repeat _ 20] +} -body { + # Verify valid data returned before error generated + set fd [open $path(test1)] + fconfigure $fd -blocking 0 -buffersize 10 -translation lf -eofchar {} + set result {} + lappend result [read $fd] + lappend result [tell $fd] + lappend result [catch {read $fd} e d] [dict get $d -code] [dict get $d -errorcode] [tell $fd] +} -cleanup { + close $fd +} -result {X 1 1 1 {POSIX EILSEQ {invalid or incomplete multibyte or wide character}} 1} + +test bug-73bb43fb-4 { + Non-blocking+buffer size+encoding error panic - TCL bug 73bb42fb +} -body { + # Original Sergey's repro script from ticket. Only check no crash + set f [open [list | [info nameofexecutable] << {fconfigure stdout -translation binary; puts \xD6[string repeat _ 20]}]] + fconfigure $f -blocking 0 -buffersize 10 -translation lf -eofchar {} + catch {while {![string length [set d [read $f]]]} {after 10}} e d + close $f + list [dict get $d -code] [dict get $d -errorcode] +} -result {1 {POSIX EILSEQ {invalid or incomplete multibyte or wide character}}} # cleanup foreach file [list fooBar longfile script2 output test1 pipe my_script \ -- cgit v0.12 From 5059bde3ee737442a96d26361033085dcdb7ac9d Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Wed, 5 Mar 2025 06:44:06 +0000 Subject: Test case comment clarification --- tests/io.test | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/tests/io.test b/tests/io.test index 88986a7..11aa0fa 100644 --- a/tests/io.test +++ b/tests/io.test @@ -9951,7 +9951,8 @@ test io-77.2 {open pipe encoding mismatch - use replace profile} -setup { } -result a\uFFFDb test bug-73bb42fb-1 { - Non-blocking+buffer size+encoding error panic - TCL bug 73bb42fb + Non-blocking+buffer size+encoding error panic - TCL bug 73bb42fb. + Verify error at offset 0. } -setup { writeFile $path(test1) binary \xD6[string repeat _ 20] } -body { @@ -9963,11 +9964,11 @@ test bug-73bb42fb-1 { } -result {1 1 {POSIX EILSEQ {invalid or incomplete multibyte or wide character}} 0} test bug-73bb42fb-2 { - Non-blocking+buffer size+encoding error panic - TCL bug 73bb42fb + Non-blocking+buffer size+encoding error panic - TCL bug 73bb42fb. + Verify single char valid read does not fail. } -setup { writeFile $path(test1) binary X\xD6[string repeat _ 20] } -body { - # Verify single char read does not fail set fd [open $path(test1)] fconfigure $fd -blocking 0 -buffersize 10 -translation lf -eofchar {} read $fd 1 @@ -9976,11 +9977,11 @@ test bug-73bb42fb-2 { } -result X test bug-73bb43fb-3 { - Non-blocking+buffer size+encoding error panic - TCL bug 73bb42fb + Non-blocking+buffer size+encoding error panic - TCL bug 73bb42fb. + Verify valid data returned before error generated. } -setup { writeFile $path(test1) binary X\xD6[string repeat _ 20] } -body { - # Verify valid data returned before error generated set fd [open $path(test1)] fconfigure $fd -blocking 0 -buffersize 10 -translation lf -eofchar {} set result {} @@ -9992,9 +9993,9 @@ test bug-73bb43fb-3 { } -result {X 1 1 1 {POSIX EILSEQ {invalid or incomplete multibyte or wide character}} 1} test bug-73bb43fb-4 { - Non-blocking+buffer size+encoding error panic - TCL bug 73bb42fb + Non-blocking+buffer size+encoding error panic - TCL bug 73bb42fb. + Original Sergey's repro script from ticket. Only check no crash. } -body { - # Original Sergey's repro script from ticket. Only check no crash set f [open [list | [info nameofexecutable] << {fconfigure stdout -translation binary; puts \xD6[string repeat _ 20]}]] fconfigure $f -blocking 0 -buffersize 10 -translation lf -eofchar {} catch {while {![string length [set d [read $f]]]} {after 10}} e d -- cgit v0.12 From c6331ec4ede13cb46603ebbb705145925c8e2522 Mon Sep 17 00:00:00 2001 From: sebres Date: Wed, 5 Mar 2025 10:40:14 +0000 Subject: protect against enless loop (if unexpected case), be more verbose if error not happen, etc --- tests/io.test | 28 ++++++++++++++++++++-------- 1 file changed, 20 insertions(+), 8 deletions(-) diff --git a/tests/io.test b/tests/io.test index 11aa0fa..f972680 100644 --- a/tests/io.test +++ b/tests/io.test @@ -9950,7 +9950,7 @@ test io-77.2 {open pipe encoding mismatch - use replace profile} -setup { read $fd } -result a\uFFFDb -test bug-73bb42fb-1 { +test io-bug-73bb42fb-1 { Non-blocking+buffer size+encoding error panic - TCL bug 73bb42fb. Verify error at offset 0. } -setup { @@ -9963,7 +9963,7 @@ test bug-73bb42fb-1 { close $fd } -result {1 1 {POSIX EILSEQ {invalid or incomplete multibyte or wide character}} 0} -test bug-73bb42fb-2 { +test io-bug-73bb42fb-2 { Non-blocking+buffer size+encoding error panic - TCL bug 73bb42fb. Verify single char valid read does not fail. } -setup { @@ -9976,7 +9976,7 @@ test bug-73bb42fb-2 { close $fd } -result X -test bug-73bb43fb-3 { +test io-bug-73bb43fb-3 { Non-blocking+buffer size+encoding error panic - TCL bug 73bb42fb. Verify valid data returned before error generated. } -setup { @@ -9992,16 +9992,28 @@ test bug-73bb43fb-3 { close $fd } -result {X 1 1 1 {POSIX EILSEQ {invalid or incomplete multibyte or wide character}} 1} -test bug-73bb43fb-4 { +test io-bug-73bb43fb-4 { Non-blocking+buffer size+encoding error panic - TCL bug 73bb42fb. Original Sergey's repro script from ticket. Only check no crash. +} -setup { + set e "" + set timer [after 10000 {set d timeout}] + set f "" } -body { set f [open [list | [info nameofexecutable] << {fconfigure stdout -translation binary; puts \xD6[string repeat _ 20]}]] fconfigure $f -blocking 0 -buffersize 10 -translation lf -eofchar {} - catch {while {![string length [set d [read $f]]]} {after 10}} e d - close $f - list [dict get $d -code] [dict get $d -errorcode] -} -result {1 {POSIX EILSEQ {invalid or incomplete multibyte or wide character}}} + set x {} + catch { + while {$e eq "" && ![string length [set e [read $f]]]} { + after 10; update + } + set e + } e d + list $e [dict getd $d -code ""] [dict getd $d -errorcode ""] +} -cleanup { + if {$f ne ""} {close $f} + after cancel $timer +} -match glob -result {{error reading *} 1 {POSIX EILSEQ {invalid or incomplete multibyte or wide character}}} # cleanup foreach file [list fooBar longfile script2 output test1 pipe my_script \ -- cgit v0.12 From 661f405b286c19c0597f2e41c1884756d1d7b78a Mon Sep 17 00:00:00 2001 From: sebres Date: Wed, 5 Mar 2025 11:32:40 +0000 Subject: improve tests stability - read on non-blocking channel may be delayed (to next "beat" in busy notifier) and return with no data, so read blocked; one test was not need, doing the same than one below, so removed; added more verbosity in unexpected case (if no error happens for whatever reason) --- tests/io.test | 59 ++++++++++++++++++++++++++--------------------------------- 1 file changed, 26 insertions(+), 33 deletions(-) diff --git a/tests/io.test b/tests/io.test index f972680..d957d66 100644 --- a/tests/io.test +++ b/tests/io.test @@ -9950,6 +9950,20 @@ test io-77.2 {open pipe encoding mismatch - use replace profile} -setup { read $fd } -result a\uFFFDb +proc read_blocked {args} { + set timer [after 10000 {set e timeout}] + set e "" + set l 1; if {[llength $args] > 1} {set l [lindex $args 1]} + try { + while {[string length $e] < $l} { + append e [read {*}$args] + after 10; update + } + set e + } finally { + after cancel $timer + } +} test io-bug-73bb42fb-1 { Non-blocking+buffer size+encoding error panic - TCL bug 73bb42fb. Verify error at offset 0. @@ -9958,25 +9972,12 @@ test io-bug-73bb42fb-1 { } -body { set fd [open $path(test1)] fconfigure $fd -blocking 0 -buffersize 10 -translation lf -eofchar {} - list [catch {read $fd 1} e d] [dict get $d -code] [dict get $d -errorcode] [tell $fd] + list [catch {read_blocked $fd 1} e d] $e [dict getd $d -code ""] [dict getd $d -errorcode ""] [tell $fd] } -cleanup { close $fd -} -result {1 1 {POSIX EILSEQ {invalid or incomplete multibyte or wide character}} 0} +} -match glob -result {1 {error reading *} 1 {POSIX EILSEQ {invalid or incomplete multibyte or wide character}} 0} -test io-bug-73bb42fb-2 { - Non-blocking+buffer size+encoding error panic - TCL bug 73bb42fb. - Verify single char valid read does not fail. -} -setup { - writeFile $path(test1) binary X\xD6[string repeat _ 20] -} -body { - set fd [open $path(test1)] - fconfigure $fd -blocking 0 -buffersize 10 -translation lf -eofchar {} - read $fd 1 -} -cleanup { - close $fd -} -result X - -test io-bug-73bb43fb-3 { +test io-bug-73bb43fb-2 { Non-blocking+buffer size+encoding error panic - TCL bug 73bb42fb. Verify valid data returned before error generated. } -setup { @@ -9985,35 +9986,27 @@ test io-bug-73bb43fb-3 { set fd [open $path(test1)] fconfigure $fd -blocking 0 -buffersize 10 -translation lf -eofchar {} set result {} - lappend result [read $fd] + lappend result [read_blocked $fd] lappend result [tell $fd] - lappend result [catch {read $fd} e d] [dict get $d -code] [dict get $d -errorcode] [tell $fd] + lappend result [catch {read_blocked $fd} e d] $e [dict getd $d -code ""] [dict getd $d -errorcode ""] [tell $fd] } -cleanup { close $fd -} -result {X 1 1 1 {POSIX EILSEQ {invalid or incomplete multibyte or wide character}} 1} +} -match glob -result {X 1 1 {error reading *} 1 {POSIX EILSEQ {invalid or incomplete multibyte or wide character}} 1} -test io-bug-73bb43fb-4 { +test io-bug-73bb43fb-3 { Non-blocking+buffer size+encoding error panic - TCL bug 73bb42fb. - Original Sergey's repro script from ticket. Only check no crash. + Modified Sergey's repro script from ticket. Check no crash / error. } -setup { - set e "" - set timer [after 10000 {set d timeout}] set f "" } -body { set f [open [list | [info nameofexecutable] << {fconfigure stdout -translation binary; puts \xD6[string repeat _ 20]}]] fconfigure $f -blocking 0 -buffersize 10 -translation lf -eofchar {} - set x {} - catch { - while {$e eq "" && ![string length [set e [read $f]]]} { - after 10; update - } - set e - } e d - list $e [dict getd $d -code ""] [dict getd $d -errorcode ""] + list [catch { read_blocked $f } e d] $e [dict getd $d -code ""] [dict getd $d -errorcode ""] } -cleanup { if {$f ne ""} {close $f} - after cancel $timer -} -match glob -result {{error reading *} 1 {POSIX EILSEQ {invalid or incomplete multibyte or wide character}}} +} -match glob -result {1 {error reading *} 1 {POSIX EILSEQ {invalid or incomplete multibyte or wide character}}} + +rename read_blocked {} # cleanup foreach file [list fooBar longfile script2 output test1 pipe my_script \ -- cgit v0.12 From 765ab9c3a99509a2ecf1c79f8826ccf52df4a2e6 Mon Sep 17 00:00:00 2001 From: sebres Date: Wed, 5 Mar 2025 11:49:56 +0000 Subject: proper timeout handling (e is global for after-event) --- tests/io.test | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/tests/io.test b/tests/io.test index d957d66..f57a0ef 100644 --- a/tests/io.test +++ b/tests/io.test @@ -9951,7 +9951,8 @@ test io-77.2 {open pipe encoding mismatch - use replace profile} -setup { } -result a\uFFFDb proc read_blocked {args} { - set timer [after 10000 {set e timeout}] + global e + set timer [after 10000 {set ::e timeout}] set e "" set l 1; if {[llength $args] > 1} {set l [lindex $args 1]} try { @@ -9962,6 +9963,7 @@ proc read_blocked {args} { set e } finally { after cancel $timer + unset -nocomplain e } } test io-bug-73bb42fb-1 { -- cgit v0.12 From e37698c1eabb4b41b43d116ffffd201be0e9b1c0 Mon Sep 17 00:00:00 2001 From: sebres Date: Wed, 5 Mar 2025 12:31:32 +0000 Subject: prepare to cherry-pick to 8.7 (no strict by default) --- tests/io.test | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/tests/io.test b/tests/io.test index f57a0ef..1f399f9 100644 --- a/tests/io.test +++ b/tests/io.test @@ -9973,7 +9973,7 @@ test io-bug-73bb42fb-1 { writeFile $path(test1) binary \xD6[string repeat _ 20] } -body { set fd [open $path(test1)] - fconfigure $fd -blocking 0 -buffersize 10 -translation lf -eofchar {} + fconfigure $fd -profile strict -blocking 0 -buffersize 10 -translation lf -eofchar {} list [catch {read_blocked $fd 1} e d] $e [dict getd $d -code ""] [dict getd $d -errorcode ""] [tell $fd] } -cleanup { close $fd @@ -9986,7 +9986,7 @@ test io-bug-73bb43fb-2 { writeFile $path(test1) binary X\xD6[string repeat _ 20] } -body { set fd [open $path(test1)] - fconfigure $fd -blocking 0 -buffersize 10 -translation lf -eofchar {} + fconfigure $fd -profile strict -blocking 0 -buffersize 10 -translation lf -eofchar {} set result {} lappend result [read_blocked $fd] lappend result [tell $fd] @@ -10002,7 +10002,7 @@ test io-bug-73bb43fb-3 { set f "" } -body { set f [open [list | [info nameofexecutable] << {fconfigure stdout -translation binary; puts \xD6[string repeat _ 20]}]] - fconfigure $f -blocking 0 -buffersize 10 -translation lf -eofchar {} + fconfigure $f -profile strict -blocking 0 -buffersize 10 -translation lf -eofchar {} list [catch { read_blocked $f } e d] $e [dict getd $d -code ""] [dict getd $d -errorcode ""] } -cleanup { if {$f ne ""} {close $f} -- cgit v0.12 From b1c7e138862a0335e0a7328968b0d6b408d95e76 Mon Sep 17 00:00:00 2001 From: sebres Date: Wed, 5 Mar 2025 12:32:26 +0000 Subject: new test (PoC): delay between bytes of single multi-byte utf-8 char doesn't cause encoding error with profile strict. --- tests/io.test | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) diff --git a/tests/io.test b/tests/io.test index 1f399f9..d0d3557 100644 --- a/tests/io.test +++ b/tests/io.test @@ -10008,6 +10008,26 @@ test io-bug-73bb43fb-3 { if {$f ne ""} {close $f} } -match glob -result {1 {error reading *} 1 {POSIX EILSEQ {invalid or incomplete multibyte or wide character}}} +test io-bug-73bb43fb-4 { + Non-blocking+buffer size+encoding error panic - TCL bug 73bb42fb. + (PoC) Delay between bytes of single utf-8 char doesn't cause encoding error with profile strict. +} -setup { + set f "" +} -body { + set f [open [list | [info nameofexecutable] << { + fconfigure stdout -translation binary + puts -nonewline "START-"; flush stdout + foreach {ch} [split [encoding convertto \u30B3] ""] {; # 3 bytes E3 82 B3 + puts -nonewline $ch; flush stdout; if {$ch ne "\xB3"} {after 100} + } + puts -nonewline "-DONE"; flush stdout + }]] + fconfigure $f -profile strict -blocking 0 -buffersize 10 -translation lf -eofchar {} + list [catch { read_blocked $f 12 } e d] $e [dict getd $d -code ""] [dict getd $d -errorcode ""] +} -cleanup { + if {$f ne ""} {close $f} +} -result "0 START-\u30B3-DONE 0 {}" + rename read_blocked {} # cleanup -- cgit v0.12 From 6aac4d3a0981474af082ed99dae1019f98c8fa5d Mon Sep 17 00:00:00 2001 From: sebres Date: Wed, 5 Mar 2025 13:42:45 +0000 Subject: fixes [712efac3397f9954]: change mistakenly flipped args for Tcl_OpenTcpServerEx() --- generic/tclIOSock.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclIOSock.c b/generic/tclIOSock.c index 01ec325..81645c8 100644 --- a/generic/tclIOSock.c +++ b/generic/tclIOSock.c @@ -318,8 +318,8 @@ Tcl_OpenTcpServer( char portbuf[TCL_INTEGER_SPACE]; TclFormatInt(portbuf, port); - return Tcl_OpenTcpServerEx(interp, portbuf, host, -1, - TCL_TCPSERVER_REUSEADDR, acceptProc, callbackData); + return Tcl_OpenTcpServerEx(interp, portbuf, host, TCL_TCPSERVER_REUSEADDR, + -1, acceptProc, callbackData); } /* -- cgit v0.12 From 69c0f5ab8e8defae3411d5bab8822d7d2e81f641 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 5 Mar 2025 15:30:36 +0000 Subject: The "numTokens" field of Tcl_Token is now type Tcl_Size. Propagate that change through the code. --- generic/tclCompCmds.c | 5 +++-- generic/tclCompile.c | 6 +++--- generic/tclCompile.h | 4 ++-- 3 files changed, 8 insertions(+), 7 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index c6301f4..c2cba19 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -3414,10 +3414,11 @@ TclPushVarName( { const char *p; const char *last, *name, *elName; - int n; + Tcl_Size n; Tcl_Token *elemTokenPtr = NULL; int nameLen, elNameLen, simpleVarName, localIndex; - int elemTokenCount = 0, allocedTokens = 0, removedParen = 0; + 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 diff --git a/generic/tclCompile.c b/generic/tclCompile.c index d56a82c..9c8c8e7 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -2397,14 +2397,14 @@ TclCompileTokens( Tcl_Interp *interp, /* Used for error and status reporting. */ Tcl_Token *tokenPtr, /* Pointer to first in an array of tokens to * compile. */ - int count, /* Number of tokens to consider at tokenPtr. + Tcl_Size count, /* Number of tokens to consider at tokenPtr. * Must be at least 1. */ CompileEnv *envPtr) /* Holds the resulting instructions. */ { Tcl_DString textBuffer; /* Holds concatenated chars from adjacent * TCL_TOKEN_TEXT, TCL_TOKEN_BS tokens. */ char buffer[4] = ""; - int i, numObjsToConcat, adjust; + Tcl_Size i, numObjsToConcat, adjust; int length; unsigned char *entryCodeNext = envPtr->codeNext; #define NUM_STATIC_POS 20 @@ -2614,7 +2614,7 @@ TclCompileCmdWord( Tcl_Interp *interp, /* Used for error and status reporting. */ Tcl_Token *tokenPtr, /* Pointer to first in an array of tokens for * a command word to compile inline. */ - int count, /* Number of tokens to consider at tokenPtr. + Tcl_Size count, /* Number of tokens to consider at tokenPtr. * Must be at least 1. */ CompileEnv *envPtr) /* Holds the resulting instructions. */ { diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 94f16f0..46999a9 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -1099,7 +1099,7 @@ MODULE_SCOPE int TclAttemptCompileProc(Tcl_Interp *interp, MODULE_SCOPE void TclCleanupStackForBreakContinue(CompileEnv *envPtr, ExceptionAux *auxPtr); MODULE_SCOPE void TclCompileCmdWord(Tcl_Interp *interp, - Tcl_Token *tokenPtr, int count, + Tcl_Token *tokenPtr, Tcl_Size count, CompileEnv *envPtr); MODULE_SCOPE void TclCompileExpr(Tcl_Interp *interp, const char *script, Tcl_Size numBytes, CompileEnv *envPtr, int optimize); @@ -1115,7 +1115,7 @@ MODULE_SCOPE void TclCompileScript(Tcl_Interp *interp, MODULE_SCOPE void TclCompileSyntaxError(Tcl_Interp *interp, CompileEnv *envPtr); MODULE_SCOPE void TclCompileTokens(Tcl_Interp *interp, - Tcl_Token *tokenPtr, int count, + Tcl_Token *tokenPtr, Tcl_Size count, CompileEnv *envPtr); MODULE_SCOPE void TclCompileVarSubst(Tcl_Interp *interp, Tcl_Token *tokenPtr, CompileEnv *envPtr); -- cgit v0.12 From 09d84621760cae053b7278ef3dbfdbb66d0ffd23 Mon Sep 17 00:00:00 2001 From: sebres Date: Thu, 6 Mar 2025 12:50:36 +0000 Subject: fixes another variant of [73bb42fb3f35cd61] (BUFFER_PADDING panic) with more tests; increases coverage for profile strict --- generic/tclIO.c | 3 ++- tests/io.test | 80 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 82 insertions(+), 1 deletion(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 60e558c..d6eff8f 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -6144,7 +6144,8 @@ DoReadChars( } if (copiedNow < 0) { - if (GotFlag(statePtr, CHANNEL_EOF)) { + if (GotFlag(statePtr, CHANNEL_EOF) || + GotFlag(statePtr, CHANNEL_ENCODING_ERROR)) { break; } if ((GotFlag(statePtr, CHANNEL_NONBLOCKING) || allowShortReads) diff --git a/tests/io.test b/tests/io.test index 12cf8a9..04afe82 100644 --- a/tests/io.test +++ b/tests/io.test @@ -9828,6 +9828,86 @@ test io-76.10 {channel mode dropping} -setup { } -match glob -result {Tcl_RemoveChannelMode error:\ Bad mode, would make channel inacessible. Channel: "*"} +proc read_blocked {args} { + global e + set timer [after 10000 {set ::e timeout}] + set e "" + set l 1; if {[llength $args] > 1} {set l [lindex $args 1]} + try { + while {[string length $e] < $l} { + append e [read {*}$args] + after 10; update + } + set e + } finally { + after cancel $timer + unset -nocomplain e + } +} +test io-bug-73bb42fb-1 { + Non-blocking+buffer size+encoding error panic - TCL bug 73bb42fb. + Verify error at offset 0. +} -setup { + writeFile $path(test1) binary \xD6[string repeat _ 20] +} -body { + set fd [open $path(test1)] + fconfigure $fd -profile strict -blocking 0 -buffersize 10 -translation lf -eofchar {} + list [catch {read_blocked $fd 1} e d] $e [dict getd $d -code ""] [dict getd $d -errorcode ""] [tell $fd] +} -cleanup { + close $fd +} -match glob -result {1 {error reading *} 1 {POSIX EILSEQ {invalid or incomplete multibyte or wide character}} 0} + +test io-bug-73bb43fb-2 { + Non-blocking+buffer size+encoding error panic - TCL bug 73bb42fb. + Verify valid data returned before error generated. +} -setup { + writeFile $path(test1) binary X\xD6[string repeat _ 20] +} -body { + set fd [open $path(test1)] + fconfigure $fd -profile strict -blocking 0 -buffersize 10 -translation lf -eofchar {} + set result {} + lappend result [read_blocked $fd] + lappend result [tell $fd] + lappend result [catch {read_blocked $fd} e d] $e [dict getd $d -code ""] [dict getd $d -errorcode ""] [tell $fd] +} -cleanup { + close $fd +} -match glob -result {X 1 1 {error reading *} 1 {POSIX EILSEQ {invalid or incomplete multibyte or wide character}} 1} + +test io-bug-73bb43fb-3 { + Non-blocking+buffer size+encoding error panic - TCL bug 73bb42fb. + Modified Sergey's repro script from ticket. Check no crash / error. +} -setup { + set f "" +} -body { + set f [open [list | [info nameofexecutable] << {fconfigure stdout -translation binary; puts \xD6[string repeat _ 20]}]] + fconfigure $f -profile strict -blocking 0 -buffersize 10 -translation lf -eofchar {} + list [catch { read_blocked $f } e d] $e [dict getd $d -code ""] [dict getd $d -errorcode ""] +} -cleanup { + if {$f ne ""} {close $f} +} -match glob -result {1 {error reading *} 1 {POSIX EILSEQ {invalid or incomplete multibyte or wide character}}} + +test io-bug-73bb43fb-4 { + Non-blocking+buffer size+encoding error panic - TCL bug 73bb42fb. + (PoC) Delay between bytes of single utf-8 char doesn't cause encoding error with profile strict. +} -setup { + set f "" +} -body { + set f [open [list | [info nameofexecutable] << { + fconfigure stdout -translation binary + puts -nonewline "START-"; flush stdout + foreach {ch} [split [encoding convertto \u30B3] ""] {; # 3 bytes E3 82 B3 + puts -nonewline $ch; flush stdout; if {$ch ne "\xB3"} {after 100} + } + puts -nonewline "-DONE"; flush stdout + }]] + fconfigure $f -profile strict -blocking 0 -buffersize 10 -translation lf -eofchar {} + list [catch { read_blocked $f 12 } e d] $e [dict getd $d -code ""] [dict getd $d -errorcode ""] +} -cleanup { + if {$f ne ""} {close $f} +} -result "0 START-\u30B3-DONE 0 {}" + +rename read_blocked {} + # cleanup foreach file [list fooBar longfile script script2 output test1 pipe my_script \ test2 test3 cat stdout kyrillic.txt utf8-fcopy.txt utf8-rp.txt] { -- cgit v0.12 From 701394b8c39d214b0e83c967ae0911a7ec5c14e0 Mon Sep 17 00:00:00 2001 From: sebres Date: Thu, 6 Mar 2025 12:51:46 +0000 Subject: small amend fixing coverage of [73bb42fb3f35cd61] in 8.7 for windows (8.7 is not utf-8 there) --- tests/io.test | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/tests/io.test b/tests/io.test index 04afe82..200d6cd 100644 --- a/tests/io.test +++ b/tests/io.test @@ -9851,7 +9851,7 @@ test io-bug-73bb42fb-1 { writeFile $path(test1) binary \xD6[string repeat _ 20] } -body { set fd [open $path(test1)] - fconfigure $fd -profile strict -blocking 0 -buffersize 10 -translation lf -eofchar {} + fconfigure $fd -encoding utf-8 -profile strict -blocking 0 -buffersize 10 -translation lf -eofchar {} list [catch {read_blocked $fd 1} e d] $e [dict getd $d -code ""] [dict getd $d -errorcode ""] [tell $fd] } -cleanup { close $fd @@ -9864,7 +9864,7 @@ test io-bug-73bb43fb-2 { writeFile $path(test1) binary X\xD6[string repeat _ 20] } -body { set fd [open $path(test1)] - fconfigure $fd -profile strict -blocking 0 -buffersize 10 -translation lf -eofchar {} + fconfigure $fd -encoding utf-8 -profile strict -blocking 0 -buffersize 10 -translation lf -eofchar {} set result {} lappend result [read_blocked $fd] lappend result [tell $fd] @@ -9880,7 +9880,7 @@ test io-bug-73bb43fb-3 { set f "" } -body { set f [open [list | [info nameofexecutable] << {fconfigure stdout -translation binary; puts \xD6[string repeat _ 20]}]] - fconfigure $f -profile strict -blocking 0 -buffersize 10 -translation lf -eofchar {} + fconfigure $f -encoding utf-8 -profile strict -blocking 0 -buffersize 10 -translation lf -eofchar {} list [catch { read_blocked $f } e d] $e [dict getd $d -code ""] [dict getd $d -errorcode ""] } -cleanup { if {$f ne ""} {close $f} @@ -9895,12 +9895,12 @@ test io-bug-73bb43fb-4 { set f [open [list | [info nameofexecutable] << { fconfigure stdout -translation binary puts -nonewline "START-"; flush stdout - foreach {ch} [split [encoding convertto \u30B3] ""] {; # 3 bytes E3 82 B3 + foreach {ch} [split [encoding convertto utf-8 \u30B3] ""] {; # 3 bytes E3 82 B3 puts -nonewline $ch; flush stdout; if {$ch ne "\xB3"} {after 100} } puts -nonewline "-DONE"; flush stdout }]] - fconfigure $f -profile strict -blocking 0 -buffersize 10 -translation lf -eofchar {} + fconfigure $f -encoding utf-8 -profile strict -blocking 0 -buffersize 10 -translation lf -eofchar {} list [catch { read_blocked $f 12 } e d] $e [dict getd $d -code ""] [dict getd $d -errorcode ""] } -cleanup { if {$f ne ""} {close $f} -- cgit v0.12 From 82e8d56a5de1cc57850765c71d44caa794a874d4 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sun, 9 Mar 2025 03:40:55 +0000 Subject: Added comment for Bug 73bb42fb3f --- generic/tclIO.c | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index eaa3cee..bedf714 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -6063,10 +6063,21 @@ DoReadChars( } if (copiedNow < 0) { - if (GotFlag(statePtr, CHANNEL_EOF) || + /* + * copiedNow < 0 => no characters decoded in this iteration *AND* + * no source bytes consumed. This can happen if additional data + * needed to decode the next character or an invalid byte sequence + * is encountered before any data was successfully decoded. + * If at EOF, no additional data is available. If an encoding + * error is present, no progress can be made even if more data + * is available (Bug 73bb42fb3f). Either way need to break out + * of the loop. + */ + if (GotFlag(statePtr, CHANNEL_EOF) || GotFlag(statePtr, CHANNEL_ENCODING_ERROR)) { break; } + if ((GotFlag(statePtr, CHANNEL_NONBLOCKING) || allowShortReads) && GotFlag(statePtr, CHANNEL_BLOCKED)) { break; -- cgit v0.12 From b2b4b1a7d6403f3e625173688f256599d85707f1 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 9 Mar 2025 15:16:24 +0000 Subject: This is an experiment with eliminating the issuing of variable-width instructions Much complexity in the compiler and bytecode engine comes from handling both instructions with width-1 arguments and width-4 arguments. Just issuing the width-4 versions should simplify things quite a bit, at a cost of making the bytecode less dense. This experiment is to look at the consequences of that. --- generic/tclAssembly.c | 2 +- generic/tclCompCmds.c | 49 +++++--------- generic/tclCompCmdsGR.c | 48 +++----------- generic/tclCompCmdsSZ.c | 170 ++++++++++++++++++------------------------------ generic/tclCompExpr.c | 20 +++--- generic/tclCompile.c | 147 ++++++++--------------------------------- generic/tclCompile.h | 18 ++--- generic/tclExecute.c | 18 ++++- generic/tclOptimize.c | 7 +- 9 files changed, 154 insertions(+), 325 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 6575934..ff5804e 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -25,7 +25,7 @@ *- dictUpdateStart, dictUpdateEnd *- jumpTable testing *- syntax (?) - *- returnCodeBranch + *- returnCodeBranch1, returnCodeBranch4 *- tclooNext, tclooNextClass */ diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 4305fd6..0284541 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -354,14 +354,14 @@ TclCompileArraySetCmd( if (isDataEven && len == 0) { if (localIndex >= 0) { TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr); - TclEmitInstInt1(INST_JUMP_TRUE1, 7, envPtr); + TclEmitInstInt4(INST_JUMP_TRUE4, 10, envPtr); TclEmitInstInt4(INST_ARRAY_MAKE_IMM, localIndex, envPtr); } else { TclEmitOpcode( INST_DUP, envPtr); TclEmitOpcode( INST_ARRAY_EXISTS_STK, envPtr); - TclEmitInstInt1(INST_JUMP_TRUE1, 5, envPtr); + TclEmitInstInt4(INST_JUMP_TRUE4, 11, envPtr); TclEmitOpcode( INST_ARRAY_MAKE_STK, envPtr); - TclEmitInstInt1(INST_JUMP1, 3, envPtr); + TclEmitInstInt4(INST_JUMP4, 6, envPtr); /* Each branch decrements stack depth, but we only take one. */ TclAdjustStackDepth(1, envPtr); TclEmitOpcode( INST_POP, envPtr); @@ -404,7 +404,7 @@ TclCompileArraySetCmd( */ TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr); - TclEmitInstInt1(INST_JUMP_TRUE1, 7, envPtr); + TclEmitInstInt4(INST_JUMP_TRUE4, 10, envPtr); TclEmitInstInt4(INST_ARRAY_MAKE_IMM, localIndex, envPtr); CompileWord(envPtr, dataTokenPtr, interp, 2); @@ -421,14 +421,14 @@ TclCompileArraySetCmd( PushStringLiteral(envPtr, "1"); TclEmitOpcode( INST_BITAND, envPtr); offsetFwd = CurrentOffset(envPtr); - TclEmitInstInt1(INST_JUMP_FALSE1, 0, envPtr); + TclEmitInstInt4(INST_JUMP_FALSE4, 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); + TclStoreInt4AtPtr(fwd, envPtr->codeStart+offsetFwd+1); } TclEmitInstInt4(INST_FOREACH_START, infoIndex, envPtr); @@ -473,15 +473,15 @@ TclCompileArrayUnsetCmd( if (localIndex >= 0) { TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr); - TclEmitInstInt1(INST_JUMP_FALSE1, 8, envPtr); + TclEmitInstInt4(INST_JUMP_FALSE4, 11, envPtr); TclEmitInstInt1(INST_UNSET_SCALAR, 1, envPtr); TclEmitInt4( localIndex, envPtr); } else { TclEmitOpcode( INST_DUP, envPtr); TclEmitOpcode( INST_ARRAY_EXISTS_STK, envPtr); - TclEmitInstInt1(INST_JUMP_FALSE1, 6, envPtr); + TclEmitInstInt4(INST_JUMP_FALSE4, 12, envPtr); TclEmitInstInt1(INST_UNSET_STK, 1, envPtr); - TclEmitInstInt1(INST_JUMP1, 3, envPtr); + TclEmitInstInt4(INST_JUMP4, 6, envPtr); /* Each branch decrements stack depth, but we only take one. */ TclAdjustStackDepth(1, envPtr); TclEmitOpcode( INST_POP, envPtr); @@ -684,10 +684,7 @@ TclCompileCatchCmd( /* Stack at this point on both branches: result returnCode */ - if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) { - Tcl_Panic("TclCompileCatchCmd: bad jump distance %" TCL_Z_MODIFIER "d", - (CurrentOffset(envPtr) - jumpFixup.codeOffset)); - } + TclFixupForwardJumpToHere(envPtr, &jumpFixup); /* * Push the return options if the caller wants them. This needs to happen @@ -1761,7 +1758,7 @@ CompileDictEachCmd( jumpDisplacement = bodyTargetOffset - CurrentOffset(envPtr); TclEmitInstInt4( INST_JUMP_FALSE4, jumpDisplacement, envPtr); endTargetOffset = CurrentOffset(envPtr); - TclEmitInstInt1( INST_JUMP1, 0, envPtr); + TclEmitInstInt4( INST_JUMP4, 0, envPtr); /* * Error handler "finally" clause, which force-terminates the iteration @@ -1791,7 +1788,7 @@ CompileDictEachCmd( TclUpdateInstInt4AtPc(INST_JUMP_TRUE4, jumpDisplacement, envPtr->codeStart + emptyTargetOffset); jumpDisplacement = CurrentOffset(envPtr) - endTargetOffset; - TclUpdateInstInt1AtPc(INST_JUMP1, jumpDisplacement, + TclUpdateInstInt4AtPc(INST_JUMP4, jumpDisplacement, envPtr->codeStart + endTargetOffset); TclEmitOpcode( INST_POP, envPtr); TclEmitOpcode( INST_POP, envPtr); @@ -1950,10 +1947,7 @@ TclCompileDictUpdateCmd( TclEmitInt4( infoIndex, envPtr); TclEmitInvoke(envPtr,INST_RETURN_STK); - if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) { - Tcl_Panic("TclCompileDictCmd(update): bad jump distance %" TCL_Z_MODIFIER "d", - CurrentOffset(envPtr) - jumpFixup.codeOffset); - } + TclFixupForwardJumpToHere(envPtr, &jumpFixup); TclStackFree(interp, keyTokenPtrs); return TCL_OK; @@ -2312,10 +2306,7 @@ TclCompileDictWithCmd( * 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); - } + TclFixupForwardJumpToHere(envPtr, &jumpFixup); return TCL_OK; } @@ -2626,20 +2617,12 @@ TclCompileForCmd( * terminates the for. */ - if (TclFixupForwardJumpToHere(envPtr, &jumpEvalCondFixup, 127)) { - bodyCodeOffset += 3; - nextCodeOffset += 3; - } - + TclFixupForwardJumpToHere(envPtr, &jumpEvalCondFixup); 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); - } + TclEmitInstInt4(INST_JUMP_TRUE4, -jumpDist, envPtr); /* * Fix the starting points of the exception ranges (may have moved due to diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 45befc7..ebe04cc 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -322,23 +322,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; - } + TclFixupForwardJumpToHere(envPtr, + jumpFalseFixupArray.fixup + jumpIndex); } else if (boolVal) { /* * We were processing an "if 1 {...}"; stop compiling scripts. @@ -413,29 +402,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); } /* @@ -629,7 +597,7 @@ TclCompileInfoCommandsCmd( TclEmitOpcode( INST_RESOLVE_COMMAND, envPtr); TclEmitOpcode( INST_DUP, envPtr); TclEmitOpcode( INST_STR_LEN, envPtr); - TclEmitInstInt1( INST_JUMP_FALSE1, 7, envPtr); + TclEmitInstInt4( INST_JUMP_FALSE4, 10, envPtr); TclEmitInstInt4( INST_LIST, 1, envPtr); return TCL_OK; @@ -1751,7 +1719,7 @@ TclCompileNamespaceQualifiersCmd( PushStringLiteral(envPtr, ":"); TclEmitOpcode( INST_STR_EQ, envPtr); off = off - CurrentOffset(envPtr); - TclEmitInstInt1( INST_JUMP_TRUE1, off, envPtr); + TclEmitInstInt4( INST_JUMP_TRUE4, off, envPtr); TclEmitOpcode( INST_STR_RANGE, envPtr); return TCL_OK; } @@ -1786,7 +1754,7 @@ TclCompileNamespaceTailCmd( TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFixup); PushStringLiteral(envPtr, "2"); TclEmitOpcode( INST_ADD, envPtr); - TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127); + TclFixupForwardJumpToHere(envPtr, &jumpFixup); PushStringLiteral(envPtr, "end"); TclEmitOpcode( INST_STR_RANGE, envPtr); return TCL_OK; diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 313cb58..77a9ff5 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -621,14 +621,14 @@ TclCompileStringIsCmd( OP( DUP); OP1( STR_CLASS, strClassType); - JUMP1( JUMP_TRUE, over); + JUMP4( JUMP_TRUE, over); OP( POP); PUSH( "0"); - JUMP1( JUMP, over2); - FIXJUMP1(over); + JUMP4( JUMP, over2); + FIXJUMP4(over); PUSH( ""); OP( STR_NEQ); - FIXJUMP1(over2); + FIXJUMP4(over2); } return TCL_OK; @@ -641,21 +641,21 @@ TclCompileStringIsCmd( case STR_IS_BOOL: if (allowEmpty) { - JUMP1( JUMP_TRUE, over); + JUMP4( JUMP_TRUE, over); PUSH( ""); OP( STR_EQ); - JUMP1( JUMP, over2); - FIXJUMP1(over); + JUMP4( JUMP, over2); + FIXJUMP4(over); OP( POP); PUSH( "1"); - FIXJUMP1(over2); + FIXJUMP4(over2); } else { OP4( REVERSE, 2); OP( POP); } return TCL_OK; case STR_IS_TRUE: - JUMP1( JUMP_TRUE, over); + JUMP4( JUMP_TRUE, over); if (allowEmpty) { PUSH( ""); OP( STR_EQ); @@ -663,12 +663,12 @@ TclCompileStringIsCmd( OP( POP); PUSH( "0"); } - FIXJUMP1( over); + FIXJUMP4( over); OP( LNOT); OP( LNOT); return TCL_OK; case STR_IS_FALSE: - JUMP1( JUMP_TRUE, over); + JUMP4( JUMP_TRUE, over); if (allowEmpty) { PUSH( ""); OP( STR_NEQ); @@ -676,7 +676,7 @@ TclCompileStringIsCmd( OP( POP); PUSH( "1"); } - FIXJUMP1( over); + FIXJUMP4( over); OP( LNOT); return TCL_OK; default: @@ -691,24 +691,24 @@ TclCompileStringIsCmd( OP( DUP); PUSH( ""); OP( STR_EQ); - JUMP1( JUMP_TRUE, isEmpty); + JUMP4( JUMP_TRUE, isEmpty); OP( NUM_TYPE); - JUMP1( JUMP_TRUE, satisfied); + JUMP4( JUMP_TRUE, satisfied); PUSH( "0"); - JUMP1( JUMP, end); - FIXJUMP1( isEmpty); + JUMP4( JUMP, end); + FIXJUMP4( isEmpty); OP( POP); - FIXJUMP1( satisfied); + FIXJUMP4( satisfied); } else { OP( NUM_TYPE); - JUMP1( JUMP_TRUE, satisfied); + JUMP4( JUMP_TRUE, satisfied); PUSH( "0"); - JUMP1( JUMP, end); + JUMP4( JUMP, end); TclAdjustStackDepth(-1, envPtr); - FIXJUMP1( satisfied); + FIXJUMP4( satisfied); } PUSH( "1"); - FIXJUMP1( end); + FIXJUMP4( end); return TCL_OK; } @@ -721,19 +721,19 @@ TclCompileStringIsCmd( OP( DUP); OP( NUM_TYPE); OP( DUP); - JUMP1( JUMP_TRUE, testNumType); + JUMP4( JUMP_TRUE, testNumType); OP( POP); PUSH( ""); OP( STR_EQ); - JUMP1( JUMP, end); + JUMP4( JUMP, end); TclAdjustStackDepth(1, envPtr); - FIXJUMP1( testNumType); + FIXJUMP4( testNumType); OP4( REVERSE, 2); OP( POP); } else { OP( NUM_TYPE); OP( DUP); - JUMP1( JUMP_FALSE, end); + JUMP4( JUMP_FALSE, end); } switch (t) { @@ -749,7 +749,7 @@ TclCompileStringIsCmd( default: break; } - FIXJUMP1( end); + FIXJUMP4( end); return TCL_OK; case STR_IS_DICT: range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); @@ -1615,10 +1615,7 @@ TclSubstCompile( TclEmitInstInt4(INST_JUMP4, 0, envPtr); /* Start */ - if (TclFixupForwardJumpToHere(envPtr, &startFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad start jump distance %" TCL_Z_MODIFIER "d", - CurrentOffset(envPtr) - startFixup.codeOffset); - } + TclFixupForwardJumpToHere(envPtr, &startFixup); } envPtr->line = bline; @@ -1654,7 +1651,7 @@ TclSubstCompile( OP( PUSH_RESULT); OP( PUSH_RETURN_CODE); OP( END_CATCH); - OP( RETURN_CODE_BRANCH); + OP( RETURN_CODE_BRANCH4); /* ERROR -> reraise it; NB: can't require BREAK/CONTINUE handling */ OP( RETURN_STK); @@ -1674,40 +1671,24 @@ TclSubstCompile( 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); - } + TclFixupForwardJumpToHere(envPtr, &breakFixup); OP( POP); OP( POP); breakJump = CurrentOffset(envPtr) - breakOffset; - if (breakJump > 127) { - OP4(JUMP4, -breakJump); - } else { - OP1(JUMP1, -breakJump); - } + OP4(JUMP4, -breakJump); 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); - } + TclFixupForwardJumpToHere(envPtr, &continueFixup); OP( POP); OP( POP); TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &endFixup); 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); - } + TclFixupForwardJumpToHere(envPtr, &returnFixup); + TclFixupForwardJumpToHere(envPtr, &otherFixup); /* * Pull the result to top of stack, discard options dict. @@ -1717,20 +1698,14 @@ TclSubstCompile( OP( POP); /* OK destination */ - if (TclFixupForwardJumpToHere(envPtr, &okFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad ok jump distance %" TCL_Z_MODIFIER "d", - CurrentOffset(envPtr) - okFixup.codeOffset); - } + TclFixupForwardJumpToHere(envPtr, &okFixup); if (count > 1) { 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); - } + TclFixupForwardJumpToHere(envPtr, &endFixup); bline = envPtr->line; } @@ -2327,16 +2302,8 @@ IssueSwitchChainedTests( */ 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; - } - } - } + TclFixupForwardJump(envPtr, &fixupArray[i], + fixupTargetArray[i] - fixupArray[i].codeOffset); } TclStackFree(interp, fixupTargetArray); TclStackFree(interp, fixupArray); @@ -2767,7 +2734,7 @@ TclCompileThrowCmd( OP4( REVERSE, 3); OP( DUP); OP( LIST_LENGTH); - OP1( JUMP_FALSE1, 16); + OP4( JUMP_FALSE4, 19); // to POPs below OP4( LIST, 2); OP44( RETURN_IMM, TCL_ERROR, 0); TclAdjustStackDepth(2, envPtr); @@ -3091,7 +3058,7 @@ IssueTryClausesInstructions( } else { PUSH( "0"); OP4( REVERSE, 2); - OP1( JUMP1, 4); + OP4( JUMP4, 7); TclAdjustStackDepth(-2, envPtr); } ExceptionRangeTarget(envPtr, range, catchOffset); @@ -3193,7 +3160,7 @@ IssueTryClausesInstructions( OP( END_CATCH); PUSH( "1"); OP( EQ); - JUMP1( JUMP_FALSE, dontChangeOptions); + JUMP4( JUMP_FALSE, dontChangeOptions); LOAD( optionsVar); OP4( REVERSE, 2); STORE( optionsVar); @@ -3202,7 +3169,7 @@ IssueTryClausesInstructions( OP4( REVERSE, 2); OP44( DICT_SET, 1, optionsVar); TclAdjustStackDepth(-1, envPtr); - FIXJUMP1( dontChangeOptions); + FIXJUMP4( dontChangeOptions); OP4( REVERSE, 2); INVOKE( RETURN_STK); } @@ -3304,7 +3271,7 @@ IssueTryClausesFinallyInstructions( } else { PUSH( "0"); OP4( REVERSE, 2); - OP1( JUMP1, 4); + OP4( JUMP4, 7); TclAdjustStackDepth(-2, envPtr); } ExceptionRangeTarget(envPtr, range, catchOffset); @@ -3410,7 +3377,7 @@ IssueTryClausesFinallyInstructions( if (forwardsNeedFixing) { forwardsNeedFixing = 0; - OP1( JUMP1, 7); + OP4( JUMP4, 10); for (j=0 ; j 127) { - TclEmitInstInt4(INST_JUMP_TRUE4, -jumpDist, envPtr); - } else { - TclEmitInstInt1(INST_JUMP_TRUE1, -jumpDist, envPtr); - } + TclEmitInstInt4(INST_JUMP_TRUE4, -jumpDist, envPtr); } else { jumpDist = CurrentOffset(envPtr) - bodyCodeOffset; - if (jumpDist > 127) { - TclEmitInstInt4(INST_JUMP4, -jumpDist, envPtr); - } else { - TclEmitInstInt1(INST_JUMP1, -jumpDist, envPtr); - } + TclEmitInstInt4(INST_JUMP4, -jumpDist, envPtr); } /* diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index e36df94..762532b 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -2432,14 +2432,12 @@ CompileExprTree( convert = 1; } target = jumpPtr->jump.codeOffset + 2; - if (TclFixupForwardJumpToHere(envPtr, &jumpPtr->jump, 127)) { - target += 3; - } + 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; @@ -2449,21 +2447,19 @@ CompileExprTree( case OR: CLANG_ASSERT(jumpPtr); pc1 = CurrentOffset(envPtr); - TclEmitInstInt1((nodePtr->lexeme == AND) ? INST_JUMP_FALSE1 - : INST_JUMP_TRUE1, 0, envPtr); + TclEmitInstInt4((nodePtr->lexeme == AND) ? INST_JUMP_FALSE4 + : INST_JUMP_TRUE4, 0, envPtr); TclEmitPush(TclRegisterLiteral(envPtr, (nodePtr->lexeme == AND) ? "1" : "0", 1, 0), envPtr); pc2 = CurrentOffset(envPtr); - TclEmitInstInt1(INST_JUMP1, 0, envPtr); + TclEmitInstInt4(INST_JUMP4, 0, envPtr); TclAdjustStackDepth(-1, envPtr); - TclStoreInt1AtPtr(CurrentOffset(envPtr) - pc1, + TclStoreInt4AtPtr(CurrentOffset(envPtr) - pc1, envPtr->codeStart + pc1 + 1); - if (TclFixupForwardJumpToHere(envPtr, &jumpPtr->jump, 127)) { - pc2 += 3; - } + TclFixupForwardJumpToHere(envPtr, &jumpPtr->jump); TclEmitPush(TclRegisterLiteral(envPtr, (nodePtr->lexeme == AND) ? "0" : "1", 1, 0), envPtr); - TclStoreInt1AtPtr(CurrentOffset(envPtr) - pc2, + TclStoreInt4AtPtr(CurrentOffset(envPtr) - pc2, envPtr->codeStart + pc2 + 1); convert = 0; freePtr = jumpPtr; diff --git a/generic/tclCompile.c b/generic/tclCompile.c index be38697..6b4fa67 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -377,7 +377,7 @@ InstructionDesc const tclInstructionTable[] = { {"nop", 1, 0, 0, {OPERAND_NONE}}, /* Do nothing */ - {"returnCodeBranch", 1, -1, 0, {OPERAND_NONE}}, + {"returnCodeBranch1", 1, -1, 0, {OPERAND_NONE}}, /* 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 @@ -672,7 +672,13 @@ InstructionDesc const tclInstructionTable[] = { /* Create constant. Variable name and value on stack. * Stack: ... varName value => ... */ - {NULL, 0, 0, 0, {OPERAND_NONE}} + {"returnCodeBranch4", 1, -1, 0, {OPERAND_NONE}}, + /* Jump to next instruction based on the return code on top of stack + * ERROR: +1; RETURN: +6; BREAK: +11; CONTINUE: +16; + * Other non-OK: +21 + */ + + {NULL, 0, 0, 0, {OPERAND_NONE}} }; /* @@ -3923,10 +3929,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: @@ -3934,9 +3938,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. * *---------------------------------------------------------------------- */ @@ -3966,13 +3969,13 @@ TclEmitForwardJump( switch (jumpType) { case TCL_UNCONDITIONAL_JUMP: - TclEmitInstInt1(INST_JUMP1, 0, envPtr); + TclEmitInstInt4(INST_JUMP4, 0, envPtr); break; case TCL_TRUE_JUMP: - TclEmitInstInt1(INST_JUMP_TRUE1, 0, envPtr); + TclEmitInstInt4(INST_JUMP_TRUE4, 0, envPtr); break; - default: - TclEmitInstInt1(INST_JUMP_FALSE1, 0, envPtr); + default: // TCL_FALSE_JUMP + TclEmitInstInt4(INST_JUMP_FALSE4, 0, envPtr); break; } } @@ -3983,74 +3986,28 @@ 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. + * Always 0. * * 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. */ + int 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); @@ -4058,63 +4015,11 @@ TclFixupForwardJump( case TCL_TRUE_JUMP: TclUpdateInstInt4AtPc(INST_JUMP_TRUE4, jumpDist, jumpPc); break; - default: + default: // TCL_FALSE_JUMP TclUpdateInstInt4AtPc(INST_JUMP_FALSE4, 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 */ + return 0; } /* @@ -4304,7 +4209,7 @@ TclEmitInvoke( } TclFinalizeLoopExceptionRange(envPtr, loopRange); - TclFixupForwardJumpToHere(envPtr, &nonTrapFixup, 127); + TclFixupForwardJumpToHere(envPtr, &nonTrapFixup); } TclCheckStackDepth(depth+1-cleanup, envPtr); } diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 3e2626c..6e07bbc 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -732,7 +732,7 @@ enum TclInstruction { /* For [subst] compilation */ INST_NOP, - INST_RETURN_CODE_BRANCH, + INST_RETURN_CODE_BRANCH1, /* For [unset] compilation */ INST_UNSET_SCALAR, @@ -833,6 +833,9 @@ enum TclInstruction { INST_CONST_IMM, INST_CONST_STK, + /* Updated [subst] compilation */ + INST_RETURN_CODE_BRANCH4, + /* The last opcode */ LAST_INST_OPCODE }; @@ -1129,9 +1132,8 @@ MODULE_SCOPE int TclNRExecuteByteCode(Tcl_Interp *interp, MODULE_SCOPE Tcl_Obj * TclFetchLiteral(CompileEnv *envPtr, Tcl_Size index); MODULE_SCOPE Tcl_Size 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, int jumpDist); MODULE_SCOPE void TclFreeCompileEnv(CompileEnv *envPtr); MODULE_SCOPE void TclFreeJumpFixupArray(JumpFixupArray *fixupArrayPtr); MODULE_SCOPE int TclGetIndexFromToken(Tcl_Token *tokenPtr, @@ -1448,14 +1450,12 @@ TclUpdateStackReqs( * 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); + * int TclFixupForwardJumpToHere(CompileEnv *envPtr, JumpFixup *fixupPtr); */ -#define TclFixupForwardJumpToHere(envPtr, fixupPtr, threshold) \ +#define TclFixupForwardJumpToHere(envPtr, fixupPtr) \ TclFixupForwardJump((envPtr), (fixupPtr), \ - (envPtr)->codeNext-(envPtr)->codeStart-(int)(fixupPtr)->codeOffset, \ - (threshold)) + (envPtr)->codeNext-(envPtr)->codeStart-(int)(fixupPtr)->codeOffset) /* * Macros to get a signed integer (GET_INT{1,2}) or an unsigned int diff --git a/generic/tclExecute.c b/generic/tclExecute.c index fced7d0..ce1b004 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -6736,7 +6736,7 @@ TEBCresume( NEXT_INST_F(1, 0, 1); break; - case INST_RETURN_CODE_BRANCH: { + case INST_RETURN_CODE_BRANCH1: { int code; if (TclGetIntFromObj(NULL, OBJ_AT_TOS, &code) != TCL_OK) { @@ -6752,6 +6752,22 @@ TEBCresume( NEXT_INST_F(2*code-1, 1, 0); } + case INST_RETURN_CODE_BRANCH4: { + int code; + + if (TclGetIntFromObj(NULL, OBJ_AT_TOS, &code) != TCL_OK) { + Tcl_Panic("INST_RETURN_CODE_BRANCH: TOS not a return code!"); + } + if (code == TCL_OK) { + Tcl_Panic("INST_RETURN_CODE_BRANCH: TOS is TCL_OK!"); + } + if (code < TCL_ERROR || code > TCL_CONTINUE) { + code = TCL_CONTINUE + 1; + } + TRACE(("\"%s\" => jump offset %d\n", O2S(OBJ_AT_TOS), 2*code-1)); + NEXT_INST_F(5*code-4, 1, 0); + } + /* * ----------------------------------------------------------------- * Start of dictionary-related instructions. diff --git a/generic/tclOptimize.c b/generic/tclOptimize.c index cf5177a..3f1a7ba 100644 --- a/generic/tclOptimize.c +++ b/generic/tclOptimize.c @@ -106,11 +106,16 @@ LocateTargetAddresses( DefineTargetAddress(tablePtr, targetInstPtr); } break; - case INST_RETURN_CODE_BRANCH: + case INST_RETURN_CODE_BRANCH1: for (i=TCL_ERROR ; i Date: Tue, 11 Mar 2025 08:27:08 +0000 Subject: Update to appleboy/ssh-action@v1.2.2 --- .github/workflows/onefiledist.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/onefiledist.yml b/.github/workflows/onefiledist.yml index 74b88bf..87c547e 100644 --- a/.github/workflows/onefiledist.yml +++ b/.github/workflows/onefiledist.yml @@ -219,7 +219,7 @@ jobs: # MUST be a literal passwordless key - name: Publish files # https://github.com/marketplace/actions/ssh-remote-commands - uses: appleboy/ssh-action@v1.2.1 + uses: appleboy/ssh-action@v1.2.2 id: ssh if: steps.rsync.outcome == 'success' with: -- cgit v0.12 From f136b4bc38528bc2db2bd6d2469d0023f5f5cdbc Mon Sep 17 00:00:00 2001 From: sebres Date: Tue, 11 Mar 2025 17:51:06 +0000 Subject: added test coverage for `clock add` with negative base (bug [482db1d796540e68]) --- tests/clock.test | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) diff --git a/tests/clock.test b/tests/clock.test index 0dfb5f3..a4ad9b8 100644 --- a/tests/clock.test +++ b/tests/clock.test @@ -35869,6 +35869,25 @@ test clock-30.32 {regression test - add no int overflow} { [clock add 2177452800 -0x7fffffff seconds -gmt 1] ] } [lrepeat 2 {29894400 34214400 0 29966400 29969100 29969153}] +test clock-30.33 {regression test - add with negative base (local seconds of the day, bug [482db1d796540e68])} { + list \ + [list \ + [clock add -631152000 27463 days 3000 seconds -timezone :CET] \ + [clock add -631152000 902 months 10 days 3000 seconds -timezone :CET] \ + [clock add -631152000 75 years 69 days 3000 seconds -timezone :CET] \ + [clock add -631152000 659112 hours 3000 seconds -timezone :CET] \ + [clock add -631152000 39546720 minutes 3000 seconds -timezone :CET] \ + [clock add -631152000 2372806200 seconds -timezone :CET] + ] \ + [list \ + [clock add -631152000 27463 days 3000 seconds -gmt 1] \ + [clock add -631152000 902 months 10 days 3000 seconds -gmt 1] \ + [clock add -631152000 75 years 69 days 3000 seconds -gmt 1] \ + [clock add -631152000 659112 hours 3000 seconds -gmt 1] \ + [clock add -631152000 39546720 minutes 3000 seconds -gmt 1] \ + [clock add -631152000 2372806200 seconds -gmt 1] + ] +} [lrepeat 2 [lrepeat 6 [expr {-631152000 + 2372806200}]]] # END testcases30 -- cgit v0.12 From 1a2e21b8c0043a436ec381e4f05ceffd67f7f644 Mon Sep 17 00:00:00 2001 From: sebres Date: Tue, 11 Mar 2025 17:53:44 +0000 Subject: fixes [482db1d796540e68]: local seconds of day shall be always positive, also for negative base (modulo operation may be negative in C) --- generic/tclClock.c | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/generic/tclClock.c b/generic/tclClock.c index 1b44200..6eb547f 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -4418,7 +4418,11 @@ ClockAddObjCmd( } /* time together as seconds of the day */ - yySecondOfDay = yySeconds = yydate.localSeconds % SECONDS_PER_DAY; + yySecondOfDay = yydate.localSeconds % SECONDS_PER_DAY; + if (yySecondOfDay < 0) { /* to positive result of mod */ + yySecondOfDay += SECONDS_PER_DAY; + } + yySeconds = yySecondOfDay; /* seconds are in localSeconds (relative base date), so reset time here */ yyHour = 0; yyMinutes = 0; -- cgit v0.12 From 9ce53dde6986c929916a9d4bfc3819898bd07c1a Mon Sep 17 00:00:00 2001 From: sebres Date: Tue, 11 Mar 2025 18:31:26 +0000 Subject: more cases for a compiler "fix" (signed-mod operation with potentially negative dividend) --- generic/tclClock.c | 19 +++++++++++++------ 1 file changed, 13 insertions(+), 6 deletions(-) diff --git a/generic/tclClock.c b/generic/tclClock.c index 6eb547f..ee06e53 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -4087,6 +4087,9 @@ ClockFreeScan( info->flags |= CLF_ASSEMBLE_SECONDS; } else { yySecondOfDay = yydate.localSeconds % SECONDS_PER_DAY; + if (yySecondOfDay < 0) { /* compiler fix for signed-mod */ + yySecondOfDay += SECONDS_PER_DAY; + } } /* @@ -4151,10 +4154,10 @@ ClockCalcRelTime( yyMonth += yyRelMonth - 1; yyYear += yyMonth / 12; m = yyMonth % 12; - /* compiler fix for negative offs - wrap y, m = (0, -1) -> (-1, 11) */ + /* compiler fix for signed-mod - wrap y, m = (0, -1) -> (-1, 11) */ if (m < 0) { + m += 12; yyYear--; - m = 12 + m; } yyMonth = m + 1; @@ -4193,7 +4196,11 @@ ClockCalcRelTime( if (newSecs / SECONDS_PER_DAY != yySecondOfDay / SECONDS_PER_DAY) { yyRelDay += newSecs / SECONDS_PER_DAY; yySecondOfDay = 0; - yyRelSeconds = newSecs % SECONDS_PER_DAY; + yyRelSeconds = (newSecs %= SECONDS_PER_DAY); + if (newSecs < 0) { /* compiler fix for signed-mod */ + yyRelSeconds += SECONDS_PER_DAY; + yyRelDay--; + } goto repeat_rel; } @@ -4292,8 +4299,8 @@ ClockWeekdaysOffs( offs = offs % 5; /* compiler fix for negative offs - wrap (0, -1) -> (-1, 4) */ if (offs < 0) { + offs += 5; weeks--; - offs = 5 + offs; } offs += 7 * weeks; @@ -4303,7 +4310,7 @@ ClockWeekdaysOffs( /* compiler fix for negative offs - wrap (0, -1) -> (-1, 6) */ if (day < 0) { - day = 7 + day; + day += 7; } resDayOfWeek = dayOfWeek + day; } @@ -4419,7 +4426,7 @@ ClockAddObjCmd( /* time together as seconds of the day */ yySecondOfDay = yydate.localSeconds % SECONDS_PER_DAY; - if (yySecondOfDay < 0) { /* to positive result of mod */ + if (yySecondOfDay < 0) { /* compiler fix for signed-mod */ yySecondOfDay += SECONDS_PER_DAY; } yySeconds = yySecondOfDay; -- cgit v0.12 From 7f5703a2b2888b4e1d441a0fa264074863bd5720 Mon Sep 17 00:00:00 2001 From: sebres Date: Wed, 12 Mar 2025 17:00:56 +0000 Subject: clock: fixes regression for clock add (and potentially free-scan) for relative time units with TZ (by jumps over DST hole with TZ): relative time tokens must be handled different to relative date tokens (1 day != 24 hours, etc) and shall be applied to UTC seconds, not to local time; passes test clock-30.34 now. --- generic/tclClock.c | 255 +++++++++++++++++++++++++++++---------------------- generic/tclDate.c | 10 +- generic/tclDate.h | 1 + generic/tclGetDate.y | 10 +- 4 files changed, 160 insertions(+), 116 deletions(-) diff --git a/generic/tclClock.c b/generic/tclClock.c index ee06e53..44a0a7e 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -98,7 +98,8 @@ static int ClockScanCommit(DateInfo *info, ClockFmtScnCmdArgs *opts); static int ClockFreeScan(DateInfo *info, Tcl_Obj *strObj, ClockFmtScnCmdArgs *opts); -static int ClockCalcRelTime(DateInfo *info); +static int ClockCalcRelTime(DateInfo *info, + ClockFmtScnCmdArgs *opts); static Tcl_ObjCmdProc ClockAddObjCmd; static int ClockValidDate(DateInfo *, ClockFmtScnCmdArgs *, int stage); @@ -3649,19 +3650,6 @@ ClockScanObjCmd( goto done; } - /* - * If no GMT and not free-scan (where valid stage 1 is done in-between), - * validate with stage 1 before local time conversion, otherwise it may - * adjust date/time tokens to valid values - */ - if ((opts.flags & CLF_VALIDATE_S1) - && info->flags & (CLF_ASSEMBLE_SECONDS|CLF_LOCALSEC)) { - ret = ClockValidDate(&yy, &opts, CLF_VALIDATE_S1); - if (ret != TCL_OK) { - goto done; - } - } - /* Convert date info structure into UTC seconds */ ret = ClockScanCommit(&yy, &opts); @@ -3706,6 +3694,18 @@ ClockScanCommit( DateInfo *info, /* Clock scan info structure */ ClockFmtScnCmdArgs *opts) /* Format, locale, timezone and base */ { + /* + * If no GMT and not free-scan (where valid stage 1 is done in-between), + * validate with stage 1 before local time conversion, otherwise it may + * adjust date/time tokens to valid values + */ + if ((opts->flags & CLF_VALIDATE_S1) + && info->flags & (CLF_ASSEMBLE_SECONDS|CLF_LOCALSEC)) { + if (ClockValidDate(info, opts, CLF_VALIDATE_S1) != TCL_OK) { + return TCL_ERROR; + } + } + /* If needed assemble julianDay using year, month, etc. */ if (info->flags & CLF_ASSEMBLE_JULIANDAY) { if (info->flags & CLF_ISO8601WEEK) { @@ -3990,7 +3990,6 @@ ClockFreeScan( { Tcl_Interp *interp = opts->interp; ClockClientData *dataPtr = opts->dataPtr; - int ret = TCL_ERROR; /* * Parse the date. The parser will fill a structure "info" with date, @@ -4006,7 +4005,7 @@ ClockFreeScan( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unable to convert date-time string \"%s\": %s", TclGetString(strObj), Tcl_GetString(Tcl_GetObjResult(interp)))); - goto done; + return TCL_ERROR; } /* @@ -4051,7 +4050,7 @@ ClockFreeScan( dataPtr->literals[LIT_GMT]); } if (opts->timezoneObj == NULL) { - goto done; + return TCL_ERROR; } // TclSetObjRef(yydate.tzName, opts->timezoneObj); @@ -4065,7 +4064,7 @@ ClockFreeScan( */ if (opts->flags & CLF_VALIDATE) { if (ClockValidDate(info, opts, CLF_VALIDATE_S1) != TCL_OK) { - goto done; + return TCL_ERROR; } } @@ -4093,15 +4092,17 @@ ClockFreeScan( } /* - * Do relative times + * Do relative times if needed. */ - ret = ClockCalcRelTime(info); + if (info->flags & CLF_RELCONV) { + if (ClockCalcRelTime(info, opts) != TCL_OK) { + return TCL_ERROR; + } + } /* Free scanning completed - date ready */ - - done: - return ret; + return TCL_OK; } /*---------------------------------------------------------------------- @@ -4120,98 +4121,76 @@ ClockFreeScan( */ int ClockCalcRelTime( - DateInfo *info) /* Date fields used for converting */ + DateInfo *info, /* Date fields used for converting */ + ClockFmtScnCmdArgs *opts) /* Command options */ { int prevDayOfWeek = yyDayOfWeek; /* preserve unchanged day of week */ /* * Because some calculations require in-between conversion of the - * julian day, we can repeat this processing multiple times + * julian day, and fixed order due to tokens precedence, + * we can repeat this processing multiple times */ repeat_rel: - if (info->flags & CLF_RELCONV) { - /* - * Relative conversion normally possible in UTC time only, because - * of possible wrong local time increment if ignores in-between DST-hole. - * (see test-cases clock-34.53, clock-34.54). - * So increment date in julianDay, but time inside day in UTC (seconds). - */ - /* add months (or years in months) */ - - if (yyRelMonth != 0) { - int m, h; - - /* if needed extract year, month, etc. again */ - if (info->flags & CLF_ASSEMBLE_DATE) { - GetGregorianEraYearDay(&yydate, GREGORIAN_CHANGE_DATE); - GetMonthDay(&yydate); - GetYearWeekDay(&yydate, GREGORIAN_CHANGE_DATE); - info->flags &= ~CLF_ASSEMBLE_DATE; - } + /* + * Relative conversion normally possible in UTC time only, because + * of possible wrong local time increment if ignores in-between DST-hole. + * (see tests clock-34.53, clock-34.54) or by jump across TZ (CET/CEST). + * So increment date in julianDay, but time inside day in UTC (seconds). + */ - /* add the requisite number of months */ - yyMonth += yyRelMonth - 1; - yyYear += yyMonth / 12; - m = yyMonth % 12; - /* compiler fix for signed-mod - wrap y, m = (0, -1) -> (-1, 11) */ - if (m < 0) { - m += 12; - yyYear--; - } - yyMonth = m + 1; + /* add relative months (or years in months) */ - /* if the day doesn't exist in the current month, repair it */ - h = hath[IsGregorianLeapYear(&yydate)][m]; - if (yyDay > h) { - yyDay = h; - } + if (yyRelMonth != 0) { + int m, h; - /* on demand (lazy) assemble julianDay using new year, month, etc. */ - info->flags |= CLF_ASSEMBLE_JULIANDAY | CLF_ASSEMBLE_SECONDS; - - yyRelMonth = 0; + /* if needed extract year, month, etc. again */ + if (info->flags & CLF_ASSEMBLE_DATE) { + GetGregorianEraYearDay(&yydate, GREGORIAN_CHANGE_DATE); + GetMonthDay(&yydate); + GetYearWeekDay(&yydate, GREGORIAN_CHANGE_DATE); + info->flags &= ~CLF_ASSEMBLE_DATE; } - /* add days (or other parts aligned to days) */ - if (yyRelDay) { - /* assemble julianDay using new year, month, etc. */ - if (info->flags & CLF_ASSEMBLE_JULIANDAY) { - GetJulianDayFromEraYearMonthDay(&yydate, GREGORIAN_CHANGE_DATE); - info->flags &= ~CLF_ASSEMBLE_JULIANDAY; - } - yydate.julianDay += yyRelDay; + /* add the requisite number of months */ + yyMonth += yyRelMonth - 1; + yyYear += yyMonth / 12; + m = yyMonth % 12; + /* compiler fix for signed-mod - wrap y, m = (0, -1) -> (-1, 11) */ + if (m < 0) { + m += 12; + yyYear--; + } + yyMonth = m + 1; - /* julianDay was changed, on demand (lazy) extract year, month, etc. again */ - info->flags |= CLF_ASSEMBLE_DATE|CLF_ASSEMBLE_SECONDS; - yyRelDay = 0; + /* if the day doesn't exist in the current month, repair it */ + h = hath[IsGregorianLeapYear(&yydate)][m]; + if (yyDay > h) { + yyDay = h; } - /* relative time (seconds), if exceeds current date, do the day conversion and - * leave rest of the increment in yyRelSeconds to add it hereafter in UTC seconds */ - if (yyRelSeconds) { - Tcl_WideInt newSecs = yySecondOfDay + yyRelSeconds; + /* on demand (lazy) assemble julianDay using new year, month, etc. */ + info->flags |= CLF_ASSEMBLE_JULIANDAY | CLF_ASSEMBLE_SECONDS; - /* if seconds increment outside of current date, increment day */ - if (newSecs / SECONDS_PER_DAY != yySecondOfDay / SECONDS_PER_DAY) { - yyRelDay += newSecs / SECONDS_PER_DAY; - yySecondOfDay = 0; - yyRelSeconds = (newSecs %= SECONDS_PER_DAY); - if (newSecs < 0) { /* compiler fix for signed-mod */ - yyRelSeconds += SECONDS_PER_DAY; - yyRelDay--; - } + yyRelMonth = 0; + } - goto repeat_rel; - } + /* add relative days (or other parts aligned to days) */ + if (yyRelDay) { + /* assemble julianDay using new year, month, etc. */ + if (info->flags & CLF_ASSEMBLE_JULIANDAY) { + GetJulianDayFromEraYearMonthDay(&yydate, GREGORIAN_CHANGE_DATE); + info->flags &= ~CLF_ASSEMBLE_JULIANDAY; } + yydate.julianDay += yyRelDay; - info->flags &= ~CLF_RELCONV; + /* julianDay was changed, on demand (lazy) extract year, month, etc. again */ + info->flags |= CLF_ASSEMBLE_DATE | CLF_ASSEMBLE_SECONDS; + yyRelDay = 0; } - /* - * Do relative (ordinal) month - */ + /* do relative (ordinal) month */ if (info->flags & CLF_ORDINALMONTH) { int monthDiff; @@ -4242,14 +4221,12 @@ ClockCalcRelTime( yyYear += yyMonthOrdinalIncr; yyRelMonth += monthDiff; info->flags &= ~CLF_ORDINALMONTH; - info->flags |= CLF_RELCONV|CLF_ASSEMBLE_JULIANDAY|CLF_ASSEMBLE_SECONDS; + info->flags |= CLF_ASSEMBLE_JULIANDAY|CLF_ASSEMBLE_SECONDS; goto repeat_rel; } - /* - * Do relative weekday - */ + /* do relative weekday */ if ((info->flags & (CLF_DAYOFWEEK|CLF_HAVEDATE)) == CLF_DAYOFWEEK) { /* restore scanned day of week */ @@ -4270,6 +4247,61 @@ ClockCalcRelTime( info->flags |= CLF_ASSEMBLE_DATE|CLF_ASSEMBLE_SECONDS; } + /* If relative time is there, adjust it in UTC as mentioned above. */ + if (yyRelSeconds) { + /* + * If timezone is not GMT/UTC (due to DST-hole, local time offset), + * we shall do in-between conversion to UTC to append seconds there + * and hereafter convert back to TZ, otherwise apply it direct here. + */ + if (opts->timezoneObj != opts->dataPtr->literals[LIT_GMT]) { + /* + * Convert date info structure into UTC seconds and add relative + * seconds (happens in commit). + */ + if (ClockScanCommit(info, opts) != TCL_OK) { + return TCL_ERROR; + } + yyRelSeconds = 0; + /* Convert it back */ + if (ClockGetDateFields(opts->dataPtr, opts->interp, &yydate, + opts->timezoneObj, GREGORIAN_CHANGE_DATE) != TCL_OK) { + /* TODO - GREGORIAN_CHANGE_DATE should be locale-dependent */ + return TCL_ERROR; + } + /* time together as seconds of the day */ + yySecondOfDay = yydate.localSeconds % SECONDS_PER_DAY; + if (yySecondOfDay < 0) { /* compiler fix for signed-mod */ + yySecondOfDay += SECONDS_PER_DAY; + } + /* restore scanned day of week */ + yyDayOfWeek = prevDayOfWeek; + } else { + /* + * GMT/UTC zone, so no DST and no offsets - apply it here, so that + * if time exceeds current date, do the day conversion and leave the + * rest of increment in yyRelSeconds (add it later in UTC by commit) + */ + Tcl_WideInt newSecs = yySecondOfDay + yyRelSeconds; + + /* if seconds increment outside of current date, increment day */ + if (newSecs / SECONDS_PER_DAY != yySecondOfDay / SECONDS_PER_DAY) { + yyRelDay += newSecs / SECONDS_PER_DAY; + yySecondOfDay = 0; + yyRelSeconds = (newSecs %= SECONDS_PER_DAY); + if (newSecs < 0) { /* compiler fix for signed-mod */ + yyRelSeconds += SECONDS_PER_DAY; + yyRelDay--; + } + + goto repeat_rel; + } + } + } + + /* done, reset flag */ + info->flags &= ~CLF_RELCONV; + return TCL_OK; } @@ -4400,7 +4432,7 @@ ClockAddObjCmd( CLC_ADD_DAYS, CLC_ADD_WEEKDAYS, CLC_ADD_HOURS, CLC_ADD_MINUTES, CLC_ADD_SECONDS }; - int unitIndex; /* Index of an option. */ + int unitIndex = CLC_ADD_SECONDS; /* Index of an option. */ Tcl_Size i; Tcl_WideInt offs; @@ -4464,23 +4496,18 @@ ClockAddObjCmd( } /* if in-between conversion needed (already have relative date/time), - * correct date info, because the date may be changed, - * so refresh it now */ - - if ((info->flags & CLF_RELCONV) - && (unitIndex == CLC_ADD_WEEKDAYS - /* some months can be shorter as another */ - || yyRelMonth || yyRelDay - /* day changed */ - || yySeconds + yyRelSeconds > SECONDS_PER_DAY - || yySeconds + yyRelSeconds < 0)) { - if (ClockCalcRelTime(info) != TCL_OK) { + * correct date info, because the local date/time may be changed, so + * refresh it now (see test clock-30.34 "clock add jump over DST hole") */ + + if ((info->flags & CLF_RELCONV) || + (yyRelSeconds && unitIndex < CLC_ADD_HOURS) + ) { + if (ClockCalcRelTime(info, &opts) != TCL_OK) { goto done; } } /* process increment by offset + unit */ - info->flags |= CLF_RELCONV; switch (unitIndex) { case CLC_ADD_YEARS: yyRelMonth += offs * 12; @@ -4511,14 +4538,18 @@ ClockAddObjCmd( yyRelSeconds += offs; break; } + if (unitIndex != CLC_ADD_SECONDS) { + info->flags |= CLF_RELCONV; + } } /* - * Do relative times (if not yet already processed interim): + * Do relative times (if not yet already processed interim), + * thereby ignore relative time (it can be processed within commit). */ if (info->flags & CLF_RELCONV) { - if (ClockCalcRelTime(info) != TCL_OK) { + if (ClockCalcRelTime(info, &opts) != TCL_OK) { goto done; } } diff --git a/generic/tclDate.c b/generic/tclDate.c index 58c6bf3..6bdd237 100644 --- a/generic/tclDate.c +++ b/generic/tclDate.c @@ -1497,12 +1497,14 @@ yyreduce: case 7: /* item: ordMonth */ { yyIncrFlags(CLF_ORDINALMONTH); + info->flags |= CLF_RELCONV; } break; case 8: /* item: day */ { yyIncrFlags(CLF_DAYOFWEEK); + info->flags |= CLF_RELCONV; } break; @@ -1521,7 +1523,7 @@ yyreduce: case 11: /* item: trek */ { yyIncrFlags(CLF_TIME|CLF_HAVEDATE); - info->flags |= CLF_RELCONV; + info->flags |= CLF_TREK; } break; @@ -1782,6 +1784,7 @@ yyreduce: yyMonth = 1; yyRelDay += (((yyvsp[-2].Number)%1000)*(365 + IsLeapYear(yyYear)))/1000; yyRelSeconds += (yyvsp[0].Number) * (144LL * 60LL); + info->flags |= CLF_RELCONV; } break; @@ -1845,6 +1848,7 @@ yyreduce: { (yyval.Number) = (yyvsp[0].Number); yyRelPointer = &yyRelSeconds; + /* no flag CLF_RELCONV needed by seconds */ } break; @@ -1852,6 +1856,7 @@ yyreduce: { (yyval.Number) = (yyvsp[0].Number); yyRelPointer = &yyRelDay; + info->flags |= CLF_RELCONV; } break; @@ -1859,6 +1864,7 @@ yyreduce: { (yyval.Number) = (yyvsp[0].Number); yyRelPointer = &yyRelMonth; + info->flags |= CLF_RELCONV; } break; @@ -1882,7 +1888,7 @@ yyreduce: case 70: /* numitem: tUNUMBER */ { - if ((info->flags & (CLF_TIME|CLF_HAVEDATE|CLF_RELCONV)) == (CLF_TIME|CLF_HAVEDATE)) { + if ((info->flags & (CLF_TIME|CLF_HAVEDATE|CLF_TREK)) == (CLF_TIME|CLF_HAVEDATE)) { yyYear = (yyvsp[0].Number); } else { yyIncrFlags(CLF_TIME); diff --git a/generic/tclDate.h b/generic/tclDate.h index fea7cbd..a63eb0e 100644 --- a/generic/tclDate.h +++ b/generic/tclDate.h @@ -63,6 +63,7 @@ enum DateInfoFlags { CLF_RELCONV = 1 << 17, CLF_ORDINALMONTH = 1 << 18, + CLF_TREK = 1 << 19, /* On demand (lazy) assemble flags */ diff --git a/generic/tclGetDate.y b/generic/tclGetDate.y index 1895a5b..8a8e560 100644 --- a/generic/tclGetDate.y +++ b/generic/tclGetDate.y @@ -186,9 +186,11 @@ item : time { } | ordMonth { yyIncrFlags(CLF_ORDINALMONTH); + info->flags |= CLF_RELCONV; } | day { yyIncrFlags(CLF_DAYOFWEEK); + info->flags |= CLF_RELCONV; } | relspec { info->flags |= CLF_RELCONV; @@ -198,7 +200,7 @@ item : time { } | trek { yyIncrFlags(CLF_TIME|CLF_HAVEDATE); - info->flags |= CLF_RELCONV; + info->flags |= CLF_TREK; } | numitem ; @@ -389,6 +391,7 @@ trek : tSTARDATE INTNUM '.' tUNUMBER { yyMonth = 1; yyRelDay += (($2%1000)*(365 + IsLeapYear(yyYear)))/1000; yyRelSeconds += $4 * (144LL * 60LL); + info->flags |= CLF_RELCONV; } ; @@ -431,14 +434,17 @@ sign : '-' { unit : tSEC_UNIT { $$ = $1; yyRelPointer = &yyRelSeconds; + /* no flag CLF_RELCONV needed by seconds */ } | tDAY_UNIT { $$ = $1; yyRelPointer = &yyRelDay; + info->flags |= CLF_RELCONV; } | tMONTH_UNIT { $$ = $1; yyRelPointer = &yyRelMonth; + info->flags |= CLF_RELCONV; } ; @@ -454,7 +460,7 @@ INTNUM : tUNUMBER { ; numitem : tUNUMBER { - if ((info->flags & (CLF_TIME|CLF_HAVEDATE|CLF_RELCONV)) == (CLF_TIME|CLF_HAVEDATE)) { + if ((info->flags & (CLF_TIME|CLF_HAVEDATE|CLF_TREK)) == (CLF_TIME|CLF_HAVEDATE)) { yyYear = $1; } else { yyIncrFlags(CLF_TIME); -- cgit v0.12 From f04a802e9973a338e899d5011addf1ab19a18d4b Mon Sep 17 00:00:00 2001 From: sebres Date: Thu, 13 Mar 2025 14:15:14 +0000 Subject: small amend: enforce relative conversion for date units only (all relative time units are similar and affecting relative seconds in UTC) --- generic/tclClock.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclClock.c b/generic/tclClock.c index 44a0a7e..e589279 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -4538,13 +4538,13 @@ ClockAddObjCmd( yyRelSeconds += offs; break; } - if (unitIndex != CLC_ADD_SECONDS) { + if (unitIndex < CLC_ADD_HOURS) { /* date units only */ info->flags |= CLF_RELCONV; } } /* - * Do relative times (if not yet already processed interim), + * Do relative units (if not yet already processed interim), * thereby ignore relative time (it can be processed within commit). */ -- cgit v0.12 From cfc3f536cfd30e77438a61a1d595d99ab29678ec Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 13 Mar 2025 20:54:28 +0000 Subject: spacing --- generic/tclClock.c | 4 ++-- generic/tclOOInt.h | 10 +++++----- generic/tclResult.c | 2 +- generic/tclTest.c | 12 ++---------- generic/tclTestABSList.c | 6 +++--- win/tclWinFile.c | 6 +++--- 6 files changed, 16 insertions(+), 24 deletions(-) diff --git a/generic/tclClock.c b/generic/tclClock.c index 66bd359..ecba0c5 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -4255,7 +4255,7 @@ ClockCalcRelTime( * and hereafter convert back to TZ, otherwise apply it direct here. */ if (opts->timezoneObj != opts->dataPtr->literals[LIT_GMT]) { - /* + /* * Convert date info structure into UTC seconds and add relative * seconds (happens in commit). */ @@ -4277,7 +4277,7 @@ ClockCalcRelTime( /* restore scanned day of week */ yyDayOfWeek = prevDayOfWeek; } else { - /* + /* * GMT/UTC zone, so no DST and no offsets - apply it here, so that * if time exceeds current date, do the day conversion and leave the * rest of increment in yyRelSeconds (add it later in UTC by commit) diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index fb61ab1..28de527 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -656,7 +656,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) @@ -668,7 +668,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 @@ -681,16 +681,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/tclResult.c b/generic/tclResult.c index 5171e5f..2e7d378 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -1034,7 +1034,7 @@ Tcl_GetReturnOptions( if (result == TCL_ERROR) { if (!iPtr->errorInfo) { - /* + /* * No errorLine without errorInfo, e. g. (re)thrown only message, * this shall also avoid transfer of errorLine (if goes to child * interp), because we have anyway nothing excepting message diff --git a/generic/tclTest.c b/generic/tclTest.c index be31501..321fe5a 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -532,12 +532,10 @@ Tcltest_Init( } if (Tcl_GetCommandInfo(interp, "::tcl::build-info", &info)) { -#if TCL_MAJOR_VERSION > 8 if (info.isNativeObjectProc == 2) { Tcl_CreateObjCommand2(interp, "::tcl::test::build-info", info.objProc2, (void *)version, NULL); } else -#endif Tcl_CreateObjCommand(interp, "::tcl::test::build-info", info.objProc, (void *)version, NULL); } @@ -801,12 +799,10 @@ Tcltest_SafeInit( return TCL_ERROR; } if (Tcl_GetCommandInfo(interp, "::tcl::build-info", &info)) { -#if TCL_MAJOR_VERSION > 8 if (info.isNativeObjectProc == 2) { Tcl_CreateObjCommand2(interp, "::tcl::test::build-info", info.objProc2, (void *)version, NULL); } else -#endif Tcl_CreateObjCommand(interp, "::tcl::test::build-info", info.objProc, (void *)version, NULL); } @@ -2046,12 +2042,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); } diff --git a/generic/tclTestABSList.c b/generic/tclTestABSList.c index 7ce98cd..5971ca7 100644 --- a/generic/tclTestABSList.c +++ b/generic/tclTestABSList.c @@ -605,17 +605,17 @@ my_LStringReplace( } // move front elements to keep - for(x=0, kx=0; xstrlen && xstrlen && x Date: Thu, 13 Mar 2025 21:00:12 +0000 Subject: Prevent (unix|win)/configure being re-generated with anything else then autoconf-2.72 --- unix/configure.ac | 2 +- win/configure.ac | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/unix/configure.ac b/unix/configure.ac index 86aae29..f671d44 100644 --- a/unix/configure.ac +++ b/unix/configure.ac @@ -4,7 +4,7 @@ dnl generate the file "configure", which is run during Tcl installation dnl to configure the system for the local environment. AC_INIT([tcl],[9.1]) -AC_PREREQ([2.69]) +AC_PREREQ([2.72]) dnl This is only used when included from macosx/configure.ac m4_ifdef([SC_USE_CONFIG_HEADERS], [ diff --git a/win/configure.ac b/win/configure.ac index d951571..9c236f8 100644 --- a/win/configure.ac +++ b/win/configure.ac @@ -5,7 +5,7 @@ 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 -- cgit v0.12 From 6f9b9b347c4278fbc881a40cc13314e8b057f511 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 14 Mar 2025 10:28:56 +0000 Subject: Update github runner to ubuntu-24.04 --- .github/workflows/linux-build.yml | 2 +- .github/workflows/onefiledist.yml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/linux-build.yml b/.github/workflows/linux-build.yml index 975b1fa..74055fb 100644 --- a/.github/workflows/linux-build.yml +++ b/.github/workflows/linux-build.yml @@ -10,7 +10,7 @@ permissions: contents: read jobs: gcc: - runs-on: ubuntu-22.04 + runs-on: ubuntu-24.04 strategy: matrix: config: diff --git a/.github/workflows/onefiledist.yml b/.github/workflows/onefiledist.yml index 87c547e..6f19bc4 100644 --- a/.github/workflows/onefiledist.yml +++ b/.github/workflows/onefiledist.yml @@ -11,7 +11,7 @@ permissions: jobs: linux: name: Linux - runs-on: ubuntu-22.04 + runs-on: ubuntu-24.04 defaults: run: shell: bash -- cgit v0.12 From 38b9f7c21660c905d67abce10e4b52caa007bd21 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 14 Mar 2025 10:37:04 +0000 Subject: Update windows runner to windows-2025 --- .github/workflows/onefiledist.yml | 2 +- .github/workflows/win-build.yml | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/.github/workflows/onefiledist.yml b/.github/workflows/onefiledist.yml index 6f19bc4..69d3102 100644 --- a/.github/workflows/onefiledist.yml +++ b/.github/workflows/onefiledist.yml @@ -124,7 +124,7 @@ jobs: url: ${{ steps.upload.outputs.artifact-url }} win: name: Windows - runs-on: windows-2019 + runs-on: windows-2025 defaults: run: shell: msys2 {0} diff --git a/.github/workflows/win-build.yml b/.github/workflows/win-build.yml index 24c5385..112b656 100644 --- a/.github/workflows/win-build.yml +++ b/.github/workflows/win-build.yml @@ -12,7 +12,7 @@ env: ERROR_ON_FAILURES: 1 jobs: msvc: - runs-on: windows-2022 + runs-on: windows-2025 defaults: run: shell: powershell @@ -56,7 +56,7 @@ jobs: } timeout-minutes: 30 gcc: - runs-on: windows-2022 + runs-on: windows-2025 defaults: run: shell: msys2 {0} -- cgit v0.12 From 8e012944bf4f06d00d146177a73cb697c4eb00b3 Mon Sep 17 00:00:00 2001 From: sebres Date: Fri, 14 Mar 2025 17:31:24 +0000 Subject: padding --- generic/tclTest.c | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index 99ae05f..fa4d348 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -597,10 +597,10 @@ Tcltest_Init( if (info.isNativeObjectProc == 2) { Tcl_CreateObjCommand2(interp, "::tcl::test::build-info", info.objProc2, (void *)version, NULL); - } else + } else #endif - Tcl_CreateObjCommand(interp, "::tcl::test::build-info", - info.objProc, (void *)version, NULL); + Tcl_CreateObjCommand(interp, "::tcl::test::build-info", + info.objProc, (void *)version, NULL); } if (Tcl_PkgProvideEx(interp, "tcl::test", TCL_PATCH_LEVEL, NULL) == TCL_ERROR) { return TCL_ERROR; @@ -865,10 +865,10 @@ Tcltest_SafeInit( if (info.isNativeObjectProc == 2) { Tcl_CreateObjCommand2(interp, "::tcl::test::build-info", info.objProc2, (void *)version, NULL); - } else + } else #endif - Tcl_CreateObjCommand(interp, "::tcl::test::build-info", - info.objProc, (void *)version, NULL); + Tcl_CreateObjCommand(interp, "::tcl::test::build-info", + info.objProc, (void *)version, NULL); } if (Tcl_PkgProvideEx(interp, "tcl::test", TCL_PATCH_LEVEL, NULL) == TCL_ERROR) { return TCL_ERROR; -- cgit v0.12 From 2ee73911e6d04b8888fbeef91d819584e58210b0 Mon Sep 17 00:00:00 2001 From: sebres Date: Fri, 14 Mar 2025 17:37:15 +0000 Subject: code deduplication --- generic/tclTest.c | 55 ++++++++++++++++++++++++------------------------------- 1 file changed, 24 insertions(+), 31 deletions(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index fa4d348..820dd0f 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -573,39 +573,47 @@ static const char version[] = TCL_PATCH_LEVEL "+" STRINGIFY(TCL_VERSION_UUID) ; int -Tcltest_Init( +TestCommonInit( Tcl_Interp *interp) /* Interpreter for application. */ { Tcl_CmdInfo info; - Tcl_Obj **objv, *objPtr; - Tcl_Size objc; - int index; - static const char *const specialOptions[] = { - "-appinitprocerror", "-appinitprocdeleteinterp", - "-appinitprocclosestderr", "-appinitprocsetrcfile", NULL - }; if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) { return TCL_ERROR; } - if (Tcl_OOInitStubs(interp) == NULL) { - return TCL_ERROR; - } - if (Tcl_GetCommandInfo(interp, "::tcl::build-info", &info)) { -#if TCL_MAJOR_VERSION > 8 if (info.isNativeObjectProc == 2) { Tcl_CreateObjCommand2(interp, "::tcl::test::build-info", info.objProc2, (void *)version, NULL); - } else -#endif + } else { Tcl_CreateObjCommand(interp, "::tcl::test::build-info", info.objProc, (void *)version, NULL); + } } if (Tcl_PkgProvideEx(interp, "tcl::test", TCL_PATCH_LEVEL, NULL) == TCL_ERROR) { return TCL_ERROR; } + return TCL_OK; +} + +int +Tcltest_Init( + Tcl_Interp *interp) /* Interpreter for application. */ +{ + Tcl_Obj **objv, *objPtr; + Tcl_Size objc; + int index; + static const char *const specialOptions[] = { + "-appinitprocerror", "-appinitprocdeleteinterp", + "-appinitprocclosestderr", "-appinitprocsetrcfile", NULL + }; + if (TestCommonInit(interp) != TCL_OK) { + return TCL_ERROR; + } + if (Tcl_OOInitStubs(interp) == NULL) { + return TCL_ERROR; + } /* * Create additional commands and math functions for testing Tcl. */ @@ -855,22 +863,7 @@ int Tcltest_SafeInit( Tcl_Interp *interp) /* Interpreter for application. */ { - Tcl_CmdInfo info; - - if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) { - return TCL_ERROR; - } - if (Tcl_GetCommandInfo(interp, "::tcl::build-info", &info)) { -#if TCL_MAJOR_VERSION > 8 - if (info.isNativeObjectProc == 2) { - Tcl_CreateObjCommand2(interp, "::tcl::test::build-info", - info.objProc2, (void *)version, NULL); - } else -#endif - Tcl_CreateObjCommand(interp, "::tcl::test::build-info", - info.objProc, (void *)version, NULL); - } - if (Tcl_PkgProvideEx(interp, "tcl::test", TCL_PATCH_LEVEL, NULL) == TCL_ERROR) { + if (TestCommonInit(interp) != TCL_OK) { return TCL_ERROR; } return Procbodytest_SafeInit(interp); -- cgit v0.12 From bbae6c89e7c17006f7cc6acc6628698b89ef333c Mon Sep 17 00:00:00 2001 From: sebres Date: Fri, 14 Mar 2025 18:01:42 +0000 Subject: missing static --- generic/tclTest.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index 820dd0f..b9233ae 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -572,7 +572,7 @@ static const char version[] = TCL_PATCH_LEVEL "+" STRINGIFY(TCL_VERSION_UUID) #endif ; -int +static int TestCommonInit( Tcl_Interp *interp) /* Interpreter for application. */ { -- cgit v0.12 From fc90f71dfd7696b12d2f01fa701fdf0f7c81b4b5 Mon Sep 17 00:00:00 2001 From: sebres Date: Sat, 15 Mar 2025 21:04:25 +0000 Subject: make dist: "repair" target dist if required autoconf version is not available (AC_PREREQ too high), simply out a warning and use provided pregenerated configure-script; fixes GHA linux builds after [cb6436f077eda464], e.g. if checkout unix/configure gets older mtime than unix/configure.ac (or if unix/configure didn't updated, but unix/configure.ac changed so got newer mtime). --- unix/Makefile.in | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/unix/Makefile.in b/unix/Makefile.in index 6185b71..f5f0fff 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -2255,7 +2255,8 @@ 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 + cd $(UNIX_DIR); autoconf || \ + echo "WARNING: Unable to rebuild $(UNIX_DIR)/configure, use original." $(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 -- cgit v0.12 From 06a7c01750564de9e5ce1b1ea803b514f55683f3 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 16 Mar 2025 12:25:45 +0000 Subject: Conclusion: it's a little bit to early to require autoconf-2.72, since even ubuntu-24.04 doesn't have it yet. --- unix/configure.ac | 2 +- win/configure.ac | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/unix/configure.ac b/unix/configure.ac index f671d44..8824ea0 100644 --- a/unix/configure.ac +++ b/unix/configure.ac @@ -4,7 +4,7 @@ dnl generate the file "configure", which is run during Tcl installation dnl to configure the system for the local environment. AC_INIT([tcl],[9.1]) -AC_PREREQ([2.72]) +AC_PREREQ([2.71]) dnl This is only used when included from macosx/configure.ac m4_ifdef([SC_USE_CONFIG_HEADERS], [ diff --git a/win/configure.ac b/win/configure.ac index 9c236f8..860a1d1 100644 --- a/win/configure.ac +++ b/win/configure.ac @@ -5,7 +5,7 @@ AC_INIT([tcl],[9.1]) AC_CONFIG_SRCDIR([../generic/tcl.h]) -AC_PREREQ([2.72]) +AC_PREREQ([2.71]) # The following define is needed when building with Cygwin since newer # versions of autoconf incorrectly set SHELL to /bin/bash instead of -- cgit v0.12 From 26ce8d839e456aeb597969c55d92f3ae2a0d279c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 16 Mar 2025 16:44:08 +0000 Subject: Backout [338a305591] for 8.7 and 9.0: autoconf-2.69 is so common nowadays, we want an errormessage for autoconf versions < 2.69 --- unix/Makefile.in | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/unix/Makefile.in b/unix/Makefile.in index f5f0fff..6185b71 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -2255,8 +2255,7 @@ 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 || \ - echo "WARNING: Unable to rebuild $(UNIX_DIR)/configure, use original." + 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 -- cgit v0.12 From 72222df5091edde309dfe546023dbb8a135dc948 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 17 Mar 2025 11:49:44 +0000 Subject: Proposed fix for [17960b80db]: Missing libtcl?.?.dll.a in Cygwin --- unix/configure | 7 ++++++- unix/configure.ac | 5 +++++ unix/tcl.m4 | 2 +- 3 files changed, 12 insertions(+), 2 deletions(-) diff --git a/unix/configure b/unix/configure index bc06954..cf02b2c 100755 --- a/unix/configure +++ b/unix/configure @@ -5950,7 +5950,7 @@ fi ;; CYGWIN_*|MINGW32_*|MSYS_*) SHLIB_CFLAGS="-fno-common" - SHLIB_LD='${CC} -shared' + SHLIB_LD='${CC} -shared -Wl,--out-implib,$(patsubst cyg%.dll,lib%.dll.a,${LIB_FILE})' SHLIB_SUFFIX=".dll" DL_OBJS="tclLoadDl.o" PLAT_OBJS='${CYGWIN_OBJS}' @@ -10955,7 +10955,12 @@ fi TCL_UNSHARED_LIB_SUFFIX=${UNSHARED_LIB_SUFFIX} TCL_SHARED_LIB_SUFFIX=${SHARED_LIB_SUFFIX} +if test "$ac_cv_cygwin" = "yes" -a "$SHARED_BUILD" != "0"; then +eval "TCL_LIB_FILE=cygtcl${LIB_SUFFIX}" +EXTRA_INSTALL_BINARIES='$(INSTALL_LIBRARY) $(patsubst cyg%.dll,lib%.dll.a,${LIB_FILE}) "$(LIB_INSTALL_DIR)"' +else eval "TCL_LIB_FILE=libtcl${LIB_SUFFIX}" +fi # tclConfig.sh needs a version of the _LIB_SUFFIX that has been eval'ed # since on some platforms TCL_LIB_FILE contains shell escapes. diff --git a/unix/configure.ac b/unix/configure.ac index f671d44..f586d85 100644 --- a/unix/configure.ac +++ b/unix/configure.ac @@ -717,7 +717,12 @@ fi TCL_UNSHARED_LIB_SUFFIX=${UNSHARED_LIB_SUFFIX} TCL_SHARED_LIB_SUFFIX=${SHARED_LIB_SUFFIX} +if test "$ac_cv_cygwin" = "yes" -a "$SHARED_BUILD" != "0"; then +eval "TCL_LIB_FILE=cygtcl${LIB_SUFFIX}" +EXTRA_INSTALL_BINARIES='$(INSTALL_LIBRARY) $(patsubst cyg%.dll,lib%.dll.a,${LIB_FILE}) "$(LIB_INSTALL_DIR)"' +else eval "TCL_LIB_FILE=libtcl${LIB_SUFFIX}" +fi # tclConfig.sh needs a version of the _LIB_SUFFIX that has been eval'ed # since on some platforms TCL_LIB_FILE contains shell escapes. diff --git a/unix/tcl.m4 b/unix/tcl.m4 index 055f8c1..08ef749 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -1079,7 +1079,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ ;; CYGWIN_*|MINGW32_*|MSYS_*) SHLIB_CFLAGS="-fno-common" - SHLIB_LD='${CC} -shared' + SHLIB_LD='${CC} -shared -Wl,--out-implib,$(patsubst cyg%.dll,lib%.dll.a,${LIB_FILE})' SHLIB_SUFFIX=".dll" DL_OBJS="tclLoadDl.o" PLAT_OBJS='${CYGWIN_OBJS}' -- cgit v0.12 From 8d35c7488a207cb5575bf9579dfe8b888309fed9 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 18 Mar 2025 09:32:07 +0000 Subject: Fix [17960b80db]: Missing libtcl?.?.dll.a in Cygwin --- changes.md | 1 + unix/configure | 7 ++++++- unix/configure.ac | 5 +++++ unix/tcl.m4 | 2 +- 4 files changed, 13 insertions(+), 2 deletions(-) diff --git a/changes.md b/changes.md index 5a29559..beddc26 100644 --- a/changes.md +++ b/changes.md @@ -19,6 +19,7 @@ to the userbase. - [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) # Incompatibilities - No known incompatibilities with the Tcl 9.0.0 public interface. diff --git a/unix/configure b/unix/configure index 589499e..9ec07b0 100755 --- a/unix/configure +++ b/unix/configure @@ -5950,7 +5950,7 @@ fi ;; CYGWIN_*|MINGW32_*|MSYS_*) SHLIB_CFLAGS="-fno-common" - SHLIB_LD='${CC} -shared' + SHLIB_LD='${CC} -shared -Wl,--out-implib,$(patsubst cyg%.dll,lib%.dll.a,${LIB_FILE})' SHLIB_SUFFIX=".dll" DL_OBJS="tclLoadDl.o" PLAT_OBJS='${CYGWIN_OBJS}' @@ -10955,7 +10955,12 @@ fi TCL_UNSHARED_LIB_SUFFIX=${UNSHARED_LIB_SUFFIX} TCL_SHARED_LIB_SUFFIX=${SHARED_LIB_SUFFIX} +if test "$ac_cv_cygwin" = "yes" -a "$SHARED_BUILD" != "0"; then +eval "TCL_LIB_FILE=cygtcl${LIB_SUFFIX}" +EXTRA_INSTALL_BINARIES='$(INSTALL_LIBRARY) $(patsubst cyg%.dll,lib%.dll.a,${LIB_FILE}) "$(LIB_INSTALL_DIR)"' +else eval "TCL_LIB_FILE=libtcl${LIB_SUFFIX}" +fi # tclConfig.sh needs a version of the _LIB_SUFFIX that has been eval'ed # since on some platforms TCL_LIB_FILE contains shell escapes. diff --git a/unix/configure.ac b/unix/configure.ac index 67588cf..1d43b02 100644 --- a/unix/configure.ac +++ b/unix/configure.ac @@ -717,7 +717,12 @@ fi TCL_UNSHARED_LIB_SUFFIX=${UNSHARED_LIB_SUFFIX} TCL_SHARED_LIB_SUFFIX=${SHARED_LIB_SUFFIX} +if test "$ac_cv_cygwin" = "yes" -a "$SHARED_BUILD" != "0"; then +eval "TCL_LIB_FILE=cygtcl${LIB_SUFFIX}" +EXTRA_INSTALL_BINARIES='$(INSTALL_LIBRARY) $(patsubst cyg%.dll,lib%.dll.a,${LIB_FILE}) "$(LIB_INSTALL_DIR)"' +else eval "TCL_LIB_FILE=libtcl${LIB_SUFFIX}" +fi # tclConfig.sh needs a version of the _LIB_SUFFIX that has been eval'ed # since on some platforms TCL_LIB_FILE contains shell escapes. diff --git a/unix/tcl.m4 b/unix/tcl.m4 index 4265832..222b80f 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -1079,7 +1079,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ ;; CYGWIN_*|MINGW32_*|MSYS_*) SHLIB_CFLAGS="-fno-common" - SHLIB_LD='${CC} -shared' + SHLIB_LD='${CC} -shared -Wl,--out-implib,$(patsubst cyg%.dll,lib%.dll.a,${LIB_FILE})' SHLIB_SUFFIX=".dll" DL_OBJS="tclLoadDl.o" PLAT_OBJS='${CYGWIN_OBJS}' -- cgit v0.12 From 6d80c9d7b2f93a393aba4a4b96dc53cd24250f6b Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 18 Mar 2025 12:17:50 +0000 Subject: Switch over to using 4-byte args; mark some ops as deprecated (gcc/clang) --- generic/tclAssembly.c | 75 ++++++------------ generic/tclCompCmds.c | 140 ++++++++++++++++++---------------- generic/tclCompCmdsGR.c | 34 +++++---- generic/tclCompCmdsSZ.c | 197 +++++++++++++++++++++++++----------------------- generic/tclCompExpr.c | 24 +++--- generic/tclCompile.c | 51 +++++++------ generic/tclCompile.h | 68 +++++++++-------- generic/tclExecute.c | 74 ++++++++++++++++-- generic/tclOptimize.c | 3 + 9 files changed, 364 insertions(+), 302 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index ff5804e..6e3708c 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -159,7 +159,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 */ @@ -171,9 +170,7 @@ typedef enum { * 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_LVT4_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 @@ -388,27 +385,30 @@ 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_LVT4, INST_INCR_SCALAR4, 1, 1}, + {"incrArray", ASSEM_LVT4, INST_INCR_ARRAY4, 2, 1}, + {"incrArrayImm", ASSEM_LVT4_SINT1, + INST_INCR_ARRAY4_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_LVT4_SINT1, + INST_INCR_SCALAR4_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}, + {"jump", ASSEM_JUMP, INST_JUMP4, 0, 0}, + // For legacy code + {"jump4", ASSEM_JUMP, INST_JUMP4, 0, 0}, + {"jumpFalse", ASSEM_JUMP, INST_JUMP_FALSE4, 1, 0}, + // For legacy code + {"jumpFalse4", ASSEM_JUMP, INST_JUMP_FALSE4, 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}, + {"jumpTrue", ASSEM_JUMP, INST_JUMP_TRUE4, 1, 0}, + // For legacy code + {"jumpTrue4", ASSEM_JUMP, INST_JUMP_TRUE4, 1, 0}, {"label", ASSEM_LABEL, 0, 0, 0}, {"lappend", ASSEM_LVT, (INST_LAPPEND_SCALAR1<<8 | INST_LAPPEND_SCALAR4), @@ -504,7 +504,7 @@ static const TalInstDesc TalInstructionTable[] = { {"variable", ASSEM_LVT4, 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} }; /* @@ -1499,7 +1499,6 @@ AssembleOneLine( break; case ASSEM_JUMP: - case ASSEM_JUMP4: if (parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "label"); goto cleanup; @@ -1508,13 +1507,8 @@ AssembleOneLine( 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); - } + flags = 0; + BBEmitInstInt4(assemEnvPtr, tblIdx, 0, 0); /* * Start a new basic block at the instruction following the jump. @@ -1639,30 +1633,18 @@ AssembleOneLine( 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_LVT4_SINT1: if (parsePtr->numWords != 3) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "varName imm8"); + 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; @@ -1698,9 +1680,7 @@ 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: @@ -2379,10 +2359,6 @@ 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. - * *----------------------------------------------------------------------------- */ @@ -2415,8 +2391,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. * *----------------------------------------------------------------------------- */ diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 0284541..ac12493 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -179,13 +179,13 @@ TclCompileAppendCmd( if (localIndex < 0) { TclEmitOpcode(INST_APPEND_STK, envPtr); } else { - Emit14Inst(INST_APPEND_SCALAR, localIndex, envPtr); + TclEmitInstInt4(INST_APPEND_SCALAR4, localIndex, envPtr); } } else { if (localIndex < 0) { TclEmitOpcode(INST_APPEND_ARRAY_STK, envPtr); } else { - Emit14Inst(INST_APPEND_ARRAY, localIndex, envPtr); + TclEmitInstInt4(INST_APPEND_ARRAY4, localIndex, envPtr); } } @@ -216,7 +216,7 @@ TclCompileAppendCmd( } TclEmitInstInt4( INST_REVERSE, numWords-2, envPtr); for (i = 2 ; i < numWords ;) { - Emit14Inst( INST_APPEND_SCALAR, localIndex, envPtr); + TclEmitInstInt4( INST_APPEND_SCALAR4, localIndex, envPtr); if (++i < numWords) { TclEmitOpcode(INST_POP, envPtr); } @@ -292,6 +292,7 @@ TclCompileArraySetCmd( int fwd, offsetBack, offsetFwd; Tcl_Obj *literalObj; ForeachInfo *infoPtr; + JumpFixup arrayMade; if (parsePtr->numWords != 3) { return TCL_ERROR; @@ -353,18 +354,23 @@ TclCompileArraySetCmd( if (isDataEven && len == 0) { if (localIndex >= 0) { + JumpFixup haveArray; TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr); - TclEmitInstInt4(INST_JUMP_TRUE4, 10, envPtr); + TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, &haveArray); TclEmitInstInt4(INST_ARRAY_MAKE_IMM, localIndex, envPtr); + TclFixupForwardJumpToHere(envPtr, &haveArray); } else { + JumpFixup haveArray, arrayMade; TclEmitOpcode( INST_DUP, envPtr); TclEmitOpcode( INST_ARRAY_EXISTS_STK, envPtr); - TclEmitInstInt4(INST_JUMP_TRUE4, 11, envPtr); + TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, &haveArray); TclEmitOpcode( INST_ARRAY_MAKE_STK, envPtr); - TclEmitInstInt4(INST_JUMP4, 6, envPtr); + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &arrayMade); /* Each branch decrements stack depth, but we only take one. */ TclAdjustStackDepth(1, envPtr); + TclFixupForwardJumpToHere(envPtr, &haveArray); TclEmitOpcode( INST_POP, envPtr); + TclFixupForwardJumpToHere(envPtr, &arrayMade); } PushStringLiteral(envPtr, ""); goto done; @@ -381,7 +387,7 @@ TclCompileArraySetCmd( PushStringLiteral(envPtr, "0"); TclEmitInstInt4(INST_REVERSE, 2, envPtr); TclEmitInstInt4(INST_UPVAR, localIndex, envPtr); - TclEmitOpcode(INST_POP, envPtr); + TclEmitOpcode( INST_POP, envPtr); } /* @@ -403,9 +409,10 @@ TclCompileArraySetCmd( * Start issuing instructions to write to the array. */ - TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr); - TclEmitInstInt4(INST_JUMP_TRUE4, 10, envPtr); - TclEmitInstInt4(INST_ARRAY_MAKE_IMM, localIndex, envPtr); + TclEmitInstInt4( INST_ARRAY_EXISTS_IMM, localIndex, envPtr); + TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, &arrayMade); + TclEmitInstInt4( INST_ARRAY_MAKE_IMM, localIndex, envPtr); + TclFixupForwardJumpToHere(envPtr, &arrayMade); CompileWord(envPtr, dataTokenPtr, interp, 2); if (!isDataLiteral || !isDataValid) { @@ -416,30 +423,29 @@ TclCompileArraySetCmd( * use-case with [array set]). */ + JumpFixup ok; TclEmitOpcode( INST_DUP, envPtr); TclEmitOpcode( INST_LIST_LENGTH, envPtr); PushStringLiteral(envPtr, "1"); TclEmitOpcode( INST_BITAND, envPtr); - offsetFwd = CurrentOffset(envPtr); - TclEmitInstInt4(INST_JUMP_FALSE4, 0, envPtr); + TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &ok); 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; - TclStoreInt4AtPtr(fwd, envPtr->codeStart+offsetFwd+1); + TclFixupForwardJumpToHere(envPtr, &ok); } - TclEmitInstInt4(INST_FOREACH_START, infoIndex, envPtr); + 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); + TclEmitInstInt4( INST_LOAD_SCALAR4, keyVar, envPtr); + TclEmitInstInt4( INST_LOAD_SCALAR4, valVar, envPtr); + TclEmitInstInt4( INST_STORE_ARRAY4, localIndex, envPtr); + TclEmitOpcode( INST_POP, envPtr); infoPtr->loopCtTemp = offsetBack - CurrentOffset(envPtr); /*misuse */ - TclEmitOpcode( INST_FOREACH_STEP, envPtr); - TclEmitOpcode( INST_FOREACH_END, envPtr); + TclEmitOpcode( INST_FOREACH_STEP, envPtr); + TclEmitOpcode( INST_FOREACH_END, envPtr); TclAdjustStackDepth(-3, envPtr); PushStringLiteral(envPtr, ""); @@ -472,19 +478,24 @@ TclCompileArrayUnsetCmd( } if (localIndex >= 0) { + JumpFixup end; TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr); - TclEmitInstInt4(INST_JUMP_FALSE4, 11, envPtr); + TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &end); TclEmitInstInt1(INST_UNSET_SCALAR, 1, envPtr); TclEmitInt4( localIndex, envPtr); + TclFixupForwardJumpToHere(envPtr, &end); } else { + JumpFixup noSuchArray, end; TclEmitOpcode( INST_DUP, envPtr); TclEmitOpcode( INST_ARRAY_EXISTS_STK, envPtr); - TclEmitInstInt4(INST_JUMP_FALSE4, 12, envPtr); + TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &noSuchArray); TclEmitInstInt1(INST_UNSET_STK, 1, envPtr); - TclEmitInstInt4(INST_JUMP4, 6, envPtr); + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &end); /* Each branch decrements stack depth, but we only take one. */ TclAdjustStackDepth(1, envPtr); + TclFixupForwardJumpToHere(envPtr, &noSuchArray); TclEmitOpcode( INST_POP, envPtr); + TclFixupForwardJumpToHere(envPtr, &end); } PushStringLiteral(envPtr, ""); return TCL_OK; @@ -707,7 +718,7 @@ TclCompileCatchCmd( */ if (optsIndex != -1) { - Emit14Inst( INST_STORE_SCALAR, optsIndex, envPtr); + TclEmitInstInt4( INST_STORE_SCALAR4, optsIndex, envPtr); TclEmitOpcode( INST_POP, envPtr); } @@ -717,11 +728,11 @@ TclCompileCatchCmd( * Reverse the stack to store the result. */ - TclEmitInstInt4( INST_REVERSE, 2, envPtr); + TclEmitInstInt4( INST_REVERSE, 2, envPtr); if (resultIndex != -1) { - Emit14Inst( INST_STORE_SCALAR, resultIndex, envPtr); + TclEmitInstInt4(INST_STORE_SCALAR4, resultIndex, envPtr); } - TclEmitOpcode( INST_POP, envPtr); + TclEmitOpcode( INST_POP, envPtr); TclCheckStackDepth(depth+1, envPtr); return TCL_OK; @@ -1425,7 +1436,7 @@ TclCompileDictCreateCmd( } PushStringLiteral(envPtr, ""); - Emit14Inst( INST_STORE_SCALAR, worker, envPtr); + TclEmitInstInt4( INST_STORE_SCALAR4, worker, envPtr); TclEmitOpcode( INST_POP, envPtr); tokenPtr = TokenAfter(parsePtr->tokenPtr); for (i=1 ; i<(int)parsePtr->numWords ; i+=2) { @@ -1438,7 +1449,7 @@ TclCompileDictCreateCmd( TclAdjustStackDepth(-1, envPtr); TclEmitOpcode( INST_POP, envPtr); } - Emit14Inst( INST_LOAD_SCALAR, worker, envPtr); + TclEmitInstInt4( INST_LOAD_SCALAR4, worker, envPtr); TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); TclEmitInt4( worker, envPtr); return TCL_OK; @@ -1456,6 +1467,7 @@ TclCompileDictMergeCmd( DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; int i, workerIndex, infoIndex, outLoop; + JumpFixup end; /* * Deal with some special edge cases. Note that in the case with one @@ -1495,7 +1507,7 @@ TclCompileDictMergeCmd( CompileWord(envPtr, tokenPtr, interp, 1); TclEmitOpcode( INST_DUP, envPtr); TclEmitOpcode( INST_DICT_VERIFY, envPtr); - Emit14Inst( INST_STORE_SCALAR, workerIndex, envPtr); + TclEmitInstInt4( INST_STORE_SCALAR4, workerIndex,envPtr); TclEmitOpcode( INST_POP, envPtr); /* @@ -1506,6 +1518,8 @@ TclCompileDictMergeCmd( TclEmitInstInt4( INST_BEGIN_CATCH4, outLoop, envPtr); ExceptionRangeStarts(envPtr, outLoop); for (i=2 ; i<(int)parsePtr->numWords ; i++) { + Tcl_Size haveNext; + JumpFixup noNext; /* * Get the dictionary, and merge its pairs into the first dict (using * a small loop). @@ -1514,14 +1528,17 @@ TclCompileDictMergeCmd( tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, i); TclEmitInstInt4( INST_DICT_FIRST, infoIndex, envPtr); - TclEmitInstInt1( INST_JUMP_TRUE1, 24, envPtr); + TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, &noNext); + haveNext = CurrentOffset(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); + TclEmitInstInt4( INST_JUMP_FALSE4, haveNext - CurrentOffset(envPtr), + envPtr); + TclFixupForwardJumpToHere(envPtr, &noNext); TclEmitOpcode( INST_POP, envPtr); TclEmitOpcode( INST_POP, envPtr); TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); @@ -1534,10 +1551,10 @@ TclCompileDictMergeCmd( * Clean up any state left over. */ - Emit14Inst( INST_LOAD_SCALAR, workerIndex, envPtr); + TclEmitInstInt4( INST_LOAD_SCALAR4, workerIndex, envPtr); TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); TclEmitInt4( workerIndex, envPtr); - TclEmitInstInt1( INST_JUMP1, 18, envPtr); + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &end); /* * If an exception happens when starting to iterate over the second (and @@ -1554,7 +1571,7 @@ TclCompileDictMergeCmd( TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); TclEmitInt4( infoIndex, envPtr); TclEmitOpcode( INST_RETURN_STK, envPtr); - + TclFixupForwardJumpToHere(envPtr, &end); return TCL_OK; } @@ -1600,6 +1617,7 @@ CompileDictEachCmd( Tcl_Token *varsTokenPtr, *dictTokenPtr, *bodyTokenPtr; int keyVarIndex, valueVarIndex, nameChars, loopRange, catchRange; int infoIndex, jumpDisplacement, bodyTargetOffset, emptyTargetOffset; + JumpFixup emptyTarget, endTarget; Tcl_Size numVars; int endTargetOffset; int collectVar = -1; /* Index of temp var holding the result @@ -1684,7 +1702,7 @@ CompileDictEachCmd( if (collect == TCL_EACH_COLLECT) { PushStringLiteral(envPtr, ""); - Emit14Inst( INST_STORE_SCALAR, collectVar, envPtr); + TclEmitInstInt4(INST_STORE_SCALAR4, collectVar, envPtr); TclEmitOpcode( INST_POP, envPtr); } @@ -1705,17 +1723,16 @@ CompileDictEachCmd( ExceptionRangeStarts(envPtr, catchRange); TclEmitInstInt4( INST_DICT_FIRST, infoIndex, envPtr); - emptyTargetOffset = CurrentOffset(envPtr); - TclEmitInstInt4( INST_JUMP_TRUE4, 0, envPtr); + TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, &emptyTarget); /* * Inside the iteration, write the loop variables. */ bodyTargetOffset = CurrentOffset(envPtr); - Emit14Inst( INST_STORE_SCALAR, keyVarIndex, envPtr); + TclEmitInstInt4( INST_STORE_SCALAR4, keyVarIndex, envPtr); TclEmitOpcode( INST_POP, envPtr); - Emit14Inst( INST_STORE_SCALAR, valueVarIndex, envPtr); + TclEmitInstInt4( INST_STORE_SCALAR4, valueVarIndex, envPtr); TclEmitOpcode( INST_POP, envPtr); /* @@ -1731,7 +1748,7 @@ CompileDictEachCmd( BODY(bodyTokenPtr, 3); if (collect == TCL_EACH_COLLECT) { - Emit14Inst( INST_LOAD_SCALAR, keyVarIndex, envPtr); + TclEmitInstInt4(INST_LOAD_SCALAR4, keyVarIndex, envPtr); TclEmitInstInt4(INST_OVER, 1, envPtr); TclEmitInstInt4(INST_DICT_SET, 1, envPtr); TclEmitInt4( collectVar, envPtr); @@ -1757,8 +1774,7 @@ CompileDictEachCmd( TclEmitInstInt4( INST_DICT_NEXT, infoIndex, envPtr); jumpDisplacement = bodyTargetOffset - CurrentOffset(envPtr); TclEmitInstInt4( INST_JUMP_FALSE4, jumpDisplacement, envPtr); - endTargetOffset = CurrentOffset(envPtr); - TclEmitInstInt4( INST_JUMP4, 0, envPtr); + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &endTarget); /* * Error handler "finally" clause, which force-terminates the iteration @@ -1784,12 +1800,8 @@ 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; - TclUpdateInstInt4AtPc(INST_JUMP4, jumpDisplacement, - envPtr->codeStart + endTargetOffset); + TclFixupForwardJumpToHere(envPtr, &emptyTarget); + TclFixupForwardJumpToHere(envPtr, &endTarget); TclEmitOpcode( INST_POP, envPtr); TclEmitOpcode( INST_POP, envPtr); ExceptionRangeTarget(envPtr, loopRange, breakOffset); @@ -1805,7 +1817,7 @@ CompileDictEachCmd( TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); TclEmitInt4( infoIndex, envPtr); if (collect == TCL_EACH_COLLECT) { - Emit14Inst( INST_LOAD_SCALAR, collectVar, envPtr); + TclEmitInstInt4(INST_LOAD_SCALAR4, collectVar, envPtr); TclEmitInstInt1(INST_UNSET_SCALAR, 0, envPtr); TclEmitInt4( collectVar, envPtr); } else { @@ -2146,7 +2158,7 @@ TclCompileDictWithCmd( tokenPtr = TokenAfter(tokenPtr); } TclEmitInstInt4(INST_LIST, (int)parsePtr->numWords-3,envPtr); - Emit14Inst( INST_LOAD_SCALAR, dictVar, envPtr); + TclEmitInstInt4(INST_LOAD_SCALAR4, dictVar, envPtr); TclEmitInstInt4(INST_OVER, 1, envPtr); TclEmitOpcode( INST_DICT_EXPAND, envPtr); TclEmitInstInt4(INST_DICT_RECOMBINE_IMM, dictVar, envPtr); @@ -2156,7 +2168,7 @@ TclCompileDictWithCmd( */ PushStringLiteral(envPtr, ""); - Emit14Inst( INST_LOAD_SCALAR, dictVar, envPtr); + TclEmitInstInt4(INST_LOAD_SCALAR4, dictVar, envPtr); PushStringLiteral(envPtr, ""); TclEmitOpcode( INST_DICT_EXPAND, envPtr); TclEmitInstInt4(INST_DICT_RECOMBINE_IMM, dictVar, envPtr); @@ -2219,7 +2231,7 @@ TclCompileDictWithCmd( if (dictVar == -1) { CompileWord(envPtr, varTokenPtr, interp, 1); - Emit14Inst( INST_STORE_SCALAR, varNameTmp, envPtr); + TclEmitInstInt4( INST_STORE_SCALAR4, varNameTmp, envPtr); } tokenPtr = TokenAfter(varTokenPtr); if (gotPath) { @@ -2228,21 +2240,21 @@ TclCompileDictWithCmd( tokenPtr = TokenAfter(tokenPtr); } TclEmitInstInt4( INST_LIST, (int)parsePtr->numWords-3,envPtr); - Emit14Inst( INST_STORE_SCALAR, pathTmp, envPtr); + TclEmitInstInt4( INST_STORE_SCALAR4, pathTmp, envPtr); TclEmitOpcode( INST_POP, envPtr); } if (dictVar == -1) { TclEmitOpcode( INST_LOAD_STK, envPtr); } else { - Emit14Inst( INST_LOAD_SCALAR, dictVar, envPtr); + TclEmitInstInt4( INST_LOAD_SCALAR4, dictVar, envPtr); } if (gotPath) { - Emit14Inst( INST_LOAD_SCALAR, pathTmp, envPtr); + TclEmitInstInt4( INST_LOAD_SCALAR4, pathTmp, envPtr); } else { PushStringLiteral(envPtr, ""); } TclEmitOpcode( INST_DICT_EXPAND, envPtr); - Emit14Inst( INST_STORE_SCALAR, keysTmp, envPtr); + TclEmitInstInt4( INST_STORE_SCALAR4, keysTmp, envPtr); TclEmitOpcode( INST_POP, envPtr); /* @@ -2262,14 +2274,14 @@ TclCompileDictWithCmd( TclEmitOpcode( INST_END_CATCH, envPtr); if (dictVar == -1) { - Emit14Inst( INST_LOAD_SCALAR, varNameTmp, envPtr); + TclEmitInstInt4( INST_LOAD_SCALAR4, varNameTmp, envPtr); } if (gotPath) { - Emit14Inst( INST_LOAD_SCALAR, pathTmp, envPtr); + TclEmitInstInt4( INST_LOAD_SCALAR4, pathTmp, envPtr); } else { PushStringLiteral(envPtr, ""); } - Emit14Inst( INST_LOAD_SCALAR, keysTmp, envPtr); + TclEmitInstInt4( INST_LOAD_SCALAR4, keysTmp, envPtr); if (dictVar == -1) { TclEmitOpcode( INST_DICT_RECOMBINE_STK, envPtr); } else { @@ -2287,14 +2299,14 @@ TclCompileDictWithCmd( TclEmitOpcode( INST_PUSH_RESULT, envPtr); TclEmitOpcode( INST_END_CATCH, envPtr); if (dictVar == -1) { - Emit14Inst( INST_LOAD_SCALAR, varNameTmp, envPtr); + TclEmitInstInt4( INST_LOAD_SCALAR4, varNameTmp, envPtr); } if ((int)parsePtr->numWords > 3) { - Emit14Inst( INST_LOAD_SCALAR, pathTmp, envPtr); + TclEmitInstInt4( INST_LOAD_SCALAR4, pathTmp, envPtr); } else { PushStringLiteral(envPtr, ""); } - Emit14Inst( INST_LOAD_SCALAR, keysTmp, envPtr); + TclEmitInstInt4( INST_LOAD_SCALAR4, keysTmp, envPtr); if (dictVar == -1) { TclEmitOpcode( INST_DICT_RECOMBINE_STK, envPtr); } else { diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index ebe04cc..ccbec85 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -453,7 +453,7 @@ TclCompileIncrCmd( varTokenPtr = TokenAfter(parsePtr->tokenPtr); - PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_LARGE_INDEX, + PushVarNameWord(interp, varTokenPtr, envPtr, 0, &localIndex, &isScalar, 1); /* @@ -495,14 +495,14 @@ TclCompileIncrCmd( if (isScalar) { /* Simple scalar variable. */ if (localIndex >= 0) { if (haveImmValue) { - TclEmitInstInt1(INST_INCR_SCALAR1_IMM, localIndex, envPtr); + TclEmitInstInt4(INST_INCR_SCALAR4_IMM, localIndex, envPtr); TclEmitInt1(immValue, envPtr); } else { - TclEmitInstInt1(INST_INCR_SCALAR1, localIndex, envPtr); + TclEmitInstInt1(INST_INCR_SCALAR4, localIndex, envPtr); } } else { if (haveImmValue) { - TclEmitInstInt1(INST_INCR_STK_IMM, immValue, envPtr); + TclEmitInstInt4(INST_INCR_STK_IMM, immValue, envPtr); } else { TclEmitOpcode( INST_INCR_STK, envPtr); } @@ -510,10 +510,10 @@ TclCompileIncrCmd( } else { /* Simple array variable. */ if (localIndex >= 0) { if (haveImmValue) { - TclEmitInstInt1(INST_INCR_ARRAY1_IMM, localIndex, envPtr); + TclEmitInstInt4(INST_INCR_ARRAY4_IMM, localIndex, envPtr); TclEmitInt1(immValue, envPtr); } else { - TclEmitInstInt1(INST_INCR_ARRAY1, localIndex, envPtr); + TclEmitInstInt4(INST_INCR_ARRAY4, localIndex, envPtr); } } else { if (haveImmValue) { @@ -558,6 +558,7 @@ TclCompileInfoCommandsCmd( Tcl_Token *tokenPtr; Tcl_Obj *objPtr; const char *bytes; + JumpFixup isList; /* * We require one compile-time known argument for the case we can compile. @@ -597,8 +598,9 @@ TclCompileInfoCommandsCmd( TclEmitOpcode( INST_RESOLVE_COMMAND, envPtr); TclEmitOpcode( INST_DUP, envPtr); TclEmitOpcode( INST_STR_LEN, envPtr); - TclEmitInstInt4( INST_JUMP_FALSE4, 10, envPtr); + TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &isList); TclEmitInstInt4( INST_LIST, 1, envPtr); + TclFixupForwardJumpToHere(envPtr, &isList); return TCL_OK; notCompilable: @@ -862,13 +864,13 @@ TclCompileLappendCmd( if (localIndex < 0) { TclEmitOpcode( INST_LAPPEND_STK, envPtr); } else { - Emit14Inst( INST_LAPPEND_SCALAR, localIndex, envPtr); + TclEmitInstInt4( INST_LAPPEND_SCALAR4, localIndex, envPtr); } } else { if (localIndex < 0) { TclEmitOpcode( INST_LAPPEND_ARRAY_STK, envPtr); } else { - Emit14Inst( INST_LAPPEND_ARRAY, localIndex, envPtr); + TclEmitInstInt4( INST_LAPPEND_ARRAY4, localIndex,envPtr); } } @@ -970,7 +972,7 @@ TclCompileLassignCmd( if (localIndex >= 0) { TclEmitOpcode( INST_DUP, envPtr); TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); - Emit14Inst( INST_STORE_SCALAR, localIndex, envPtr); + TclEmitInstInt4(INST_STORE_SCALAR4, localIndex, envPtr); TclEmitOpcode( INST_POP, envPtr); } else { TclEmitInstInt4(INST_OVER, 1, envPtr); @@ -982,7 +984,7 @@ TclCompileLassignCmd( if (localIndex >= 0) { TclEmitInstInt4(INST_OVER, 1, envPtr); TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); - Emit14Inst( INST_STORE_ARRAY, localIndex, envPtr); + TclEmitInstInt4(INST_STORE_ARRAY4, localIndex, envPtr); TclEmitOpcode( INST_POP, envPtr); } else { TclEmitInstInt4(INST_OVER, 2, envPtr); @@ -1534,13 +1536,13 @@ TclCompileLsetCmd( if (localIndex < 0) { TclEmitOpcode( INST_LOAD_STK, envPtr); } else { - Emit14Inst( INST_LOAD_SCALAR, localIndex, envPtr); + TclEmitInstInt4( INST_LOAD_SCALAR4, localIndex, envPtr); } } else { if (localIndex < 0) { TclEmitOpcode( INST_LOAD_ARRAY_STK, envPtr); } else { - Emit14Inst( INST_LOAD_ARRAY, localIndex, envPtr); + TclEmitInstInt4( INST_LOAD_ARRAY4, localIndex, envPtr); } } @@ -1562,13 +1564,13 @@ TclCompileLsetCmd( if (localIndex < 0) { TclEmitOpcode( INST_STORE_STK, envPtr); } else { - Emit14Inst( INST_STORE_SCALAR, localIndex, envPtr); + TclEmitInstInt4( INST_STORE_SCALAR4, localIndex, envPtr); } } else { if (localIndex < 0) { TclEmitOpcode( INST_STORE_ARRAY_STK, envPtr); } else { - Emit14Inst( INST_STORE_ARRAY, localIndex, envPtr); + TclEmitInstInt4( INST_STORE_ARRAY4, localIndex, envPtr); } } @@ -2633,7 +2635,7 @@ TclCompileVariableCmd( */ CompileWord(envPtr, valueTokenPtr, interp, i + 1); - Emit14Inst( INST_STORE_SCALAR, localIndex, envPtr); + TclEmitInstInt4( INST_STORE_SCALAR4, localIndex, envPtr); TclEmitOpcode( INST_POP, envPtr); } } diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 77a9ff5..7d537cb 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -87,18 +87,18 @@ const AuxDataType tclJumptableInfoType = { TclEmitInstInt4(INST_##name,(val1),envPtr);TclEmitInt4((val2),envPtr) #define PUSH(str) \ PushStringLiteral(envPtr, str) +#define LABEL(var) \ + (var) = CurrentOffset(envPtr) +#define BACKJUMP4(name, var) \ + TclEmitInstInt4(INST_##name##4,(var)-CurrentOffset(envPtr),envPtr) #define JUMP4(name,var) \ - (var) = CurrentOffset(envPtr);TclEmitInstInt4(INST_##name##4,0,envPtr) + LABEL(var);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));} + OP4(LOAD_SCALAR4,(idx)) #define STORE(idx) \ - if ((idx)<256) {OP1(STORE_SCALAR1,(idx));} else {OP4(STORE_SCALAR4,(idx));} + OP4(STORE_SCALAR4,(idx)) #define INVOKE(name) \ TclEmitInvoke(envPtr,INST_##name) @@ -167,10 +167,6 @@ TclCompileSetCmd( 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); } else { TclEmitInstInt4((isAssignment? INST_STORE_SCALAR4 : INST_LOAD_SCALAR4), @@ -180,10 +176,6 @@ TclCompileSetCmd( 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); } else { TclEmitInstInt4((isAssignment? INST_STORE_ARRAY4 : INST_LOAD_ARRAY4), @@ -1545,10 +1537,9 @@ TclSubstCompile( for (endTokenPtr = tokenPtr + parse.numTokens; tokenPtr < endTokenPtr; tokenPtr = TokenAfter(tokenPtr)) { Tcl_Size length; - int literal, catchRange, breakJump; + int literal, catchRange, breakJump, end; + int haveOk, haveReturn, haveBreak, haveContinue, haveOther; char buf[4] = ""; - JumpFixup startFixup, okFixup, returnFixup, breakFixup; - JumpFixup continueFixup, otherFixup, endFixup; switch (tokenPtr->type) { case TCL_TOKEN_TEXT: @@ -1607,15 +1598,15 @@ TclSubstCompile( } if (breakOffset == 0) { + int start; /* Jump to the start (jump over the jump to end) */ - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &startFixup); + JUMP4( JUMP, start); /* Jump to the end (all BREAKs land here) */ - breakOffset = CurrentOffset(envPtr); - TclEmitInstInt4(INST_JUMP4, 0, envPtr); + JUMP4( JUMP, breakOffset); /* Start */ - TclFixupForwardJumpToHere(envPtr, &startFixup); + FIXJUMP4( start); } envPtr->line = bline; @@ -1641,80 +1632,82 @@ TclSubstCompile( ExceptionRangeEnds(envPtr, catchRange); /* Substitution produced TCL_OK */ - OP( END_CATCH); - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &okFixup); + OP( END_CATCH); + JUMP4( JUMP, haveOk); TclAdjustStackDepth(-1, envPtr); /* 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_BRANCH4); + OP( PUSH_RETURN_OPTIONS); + OP( PUSH_RESULT); + OP( PUSH_RETURN_CODE); + OP( END_CATCH); + OP( RETURN_CODE_BRANCH4); /* ERROR -> reraise it; NB: can't require BREAK/CONTINUE handling */ - OP( RETURN_STK); - OP( NOP); + OP( RETURN_STK); + OP( NOP); + OP( NOP); + OP( NOP); + OP( NOP); /* RETURN */ - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &returnFixup); + JUMP4( JUMP, haveReturn); /* BREAK */ - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &breakFixup); + JUMP4( JUMP, haveBreak); /* CONTINUE */ - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &continueFixup); + JUMP4( JUMP, haveContinue); /* OTHER */ - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &otherFixup); + JUMP4( JUMP, haveOther); TclAdjustStackDepth(1, envPtr); /* BREAK destination */ - TclFixupForwardJumpToHere(envPtr, &breakFixup); - OP( POP); - OP( POP); + FIXJUMP4( haveBreak); + OP( POP); + OP( POP); - breakJump = CurrentOffset(envPtr) - breakOffset; - OP4(JUMP4, -breakJump); + BACKJUMP4( JUMP, breakOffset); TclAdjustStackDepth(2, envPtr); /* CONTINUE destination */ - TclFixupForwardJumpToHere(envPtr, &continueFixup); - OP( POP); - OP( POP); - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &endFixup); + FIXJUMP4( haveContinue); + OP( POP); + OP( POP); + JUMP4( JUMP, end); TclAdjustStackDepth(2, envPtr); /* RETURN + other destination */ - TclFixupForwardJumpToHere(envPtr, &returnFixup); - TclFixupForwardJumpToHere(envPtr, &otherFixup); + FIXJUMP4( haveReturn); + FIXJUMP4( haveOther); /* * Pull the result to top of stack, discard options dict. */ - OP4( REVERSE, 2); - OP( POP); + OP4( REVERSE, 2); + OP( POP); /* OK destination */ - TclFixupForwardJumpToHere(envPtr, &okFixup); + FIXJUMP4( haveOk); if (count > 1) { - OP1(STR_CONCAT1, count); + OP1( STR_CONCAT1, count); count = 1; } /* CONTINUE jump to here */ - TclFixupForwardJumpToHere(envPtr, &endFixup); + FIXJUMP4( 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); @@ -1727,8 +1720,7 @@ TclSubstCompile( /* Final target of the multi-jump from all BREAKs */ if (breakOffset > 0) { - TclUpdateInstInt4AtPc(INST_JUMP4, CurrentOffset(envPtr) - breakOffset, - envPtr->codeStart + breakOffset); + FIXJUMP4( breakOffset); } } @@ -2366,10 +2358,9 @@ IssueSwitchJumpTable( * because that makes the code much easier to debug! */ - jumpLocation = CurrentOffset(envPtr); + LABEL(jumpLocation); OP4( JUMP_TABLE, infoIndex); - jumpToDefault = CurrentOffset(envPtr); - OP4( JUMP4, 0); + JUMP4( JUMP, jumpToDefault); for (i=0 ; icodeStart+jumpToDefault+1); + FIXJUMP4(jumpToDefault); } /* @@ -2452,15 +2442,13 @@ IssueSwitchJumpTable( */ 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); + JUMP4(JUMP, finalFixups[numRealBodies++]); TclAdjustStackDepth(-1, envPtr); } } @@ -2472,8 +2460,7 @@ IssueSwitchJumpTable( */ if (!foundDefault) { - TclStoreInt4AtPtr(CurrentOffset(envPtr)-jumpToDefault, - envPtr->codeStart+jumpToDefault+1); + FIXJUMP4(jumpToDefault); PUSH(""); } @@ -2483,8 +2470,7 @@ IssueSwitchJumpTable( */ for (i=0 ; icodeStart+finalFixups[i]+1); + FIXJUMP4(finalFixups[i]); } /* @@ -2727,6 +2713,7 @@ TclCompileThrowCmd( } if (!codeKnown) { + int popForError; /* * Argument validity checking has to be done by bytecode at * run time. @@ -2734,10 +2721,11 @@ TclCompileThrowCmd( OP4( REVERSE, 3); OP( DUP); OP( LIST_LENGTH); - OP4( JUMP_FALSE4, 19); // to POPs below + JUMP4( JUMP_FALSE, popForError); OP4( LIST, 2); OP44( RETURN_IMM, TCL_ERROR, 0); TclAdjustStackDepth(2, envPtr); + FIXJUMP4( popForError); OP( POP); OP( POP); OP( POP); @@ -3016,6 +3004,7 @@ IssueTryClausesInstructions( DefineLineInformation; /* TIP #280 */ int range, resultVar, optionsVar; int i, j, forwardsNeedFixing = 0, trapZero = 0, afterBody = 0; + int pushReturnOptions = 0; Tcl_Size slen, len; int *addrsToFix, *forwardsToFix, notCodeJumpSource, notECJumpSource; int *noError; @@ -3056,15 +3045,19 @@ IssueTryClausesInstructions( JUMP4( JUMP, afterBody); TclAdjustStackDepth(-1, envPtr); } else { - PUSH( "0"); + /* + * Fake a return code to go with our result. + */ OP4( REVERSE, 2); - OP4( JUMP4, 7); + JUMP4( JUMP, pushReturnOptions); TclAdjustStackDepth(-2, envPtr); } ExceptionRangeTarget(envPtr, range, catchOffset); OP( PUSH_RETURN_CODE); OP( PUSH_RESULT); - OP( PUSH_RETURN_OPTIONS); + if (pushReturnOptions) { + FIXJUMP4( pushReturnOptions); + } OP( END_CATCH); STORE( optionsVar); OP( POP); @@ -3141,7 +3134,7 @@ IssueTryClausesInstructions( if (forwardsToFix[j] == -1) { continue; } - FIXJUMP4(forwardsToFix[j]); + FIXJUMP4( forwardsToFix[j]); forwardsToFix[j] = -1; } } @@ -3176,9 +3169,9 @@ IssueTryClausesInstructions( JUMP4( JUMP, addrsToFix[i]); if (matchClauses[i]) { - FIXJUMP4( notECJumpSource); + FIXJUMP4( notECJumpSource); } - FIXJUMP4( notCodeJumpSource); + FIXJUMP4( notCodeJumpSource); } /* @@ -3198,12 +3191,12 @@ IssueTryClausesInstructions( */ if (!trapZero) { - FIXJUMP4(afterBody); + FIXJUMP4( afterBody); } for (i=0 ; iatCmdStart &= ~1; - testCodeOffset = CurrentOffset(envPtr); + LABEL(testCodeOffset); } /* @@ -3836,17 +3851,13 @@ TclCompileWhileCmd( */ if (loopMayEnd) { - testCodeOffset = CurrentOffset(envPtr); - jumpDist = testCodeOffset - jumpEvalCondFixup.codeOffset; - TclFixupForwardJump(envPtr, &jumpEvalCondFixup, jumpDist); + TclFixupForwardJumpToHere(envPtr, &jumpEvalCondFixup); SetLineInformation(1); TclCompileExprWords(interp, testTokenPtr, 1, envPtr); - jumpDist = CurrentOffset(envPtr) - bodyCodeOffset; - TclEmitInstInt4(INST_JUMP_TRUE4, -jumpDist, envPtr); + BACKJUMP4(JUMP_TRUE, bodyCodeOffset); } else { - jumpDist = CurrentOffset(envPtr) - bodyCodeOffset; - TclEmitInstInt4(INST_JUMP4, -jumpDist, envPtr); + BACKJUMP4(JUMP, bodyCodeOffset); } /* diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 762532b..e4433ff 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -2386,7 +2386,8 @@ CompileExprTree( break; } } else { - int pc1, pc2, target; + int target; + JumpFixup pc1, pc2; switch (nodePtr->lexeme) { case START: @@ -2405,11 +2406,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); - } + TclEmitInvoke(envPtr, INST_INVOKE_STK4, numWords); /* * Restore any saved numWords value. @@ -2446,21 +2443,18 @@ CompileExprTree( case AND: case OR: CLANG_ASSERT(jumpPtr); - pc1 = CurrentOffset(envPtr); - TclEmitInstInt4((nodePtr->lexeme == AND) ? INST_JUMP_FALSE4 - : INST_JUMP_TRUE4, 0, envPtr); + TclEmitForwardJump(envPtr, + (nodePtr->lexeme == AND) ? TCL_FALSE_JUMP + : TCL_TRUE_JUMP, &pc1); TclEmitPush(TclRegisterLiteral(envPtr, (nodePtr->lexeme == AND) ? "1" : "0", 1, 0), envPtr); - pc2 = CurrentOffset(envPtr); - TclEmitInstInt4(INST_JUMP4, 0, envPtr); + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &pc2); TclAdjustStackDepth(-1, envPtr); - TclStoreInt4AtPtr(CurrentOffset(envPtr) - pc1, - envPtr->codeStart + pc1 + 1); + TclFixupForwardJumpToHere(envPtr, &pc1); TclFixupForwardJumpToHere(envPtr, &jumpPtr->jump); TclEmitPush(TclRegisterLiteral(envPtr, (nodePtr->lexeme == AND) ? "0" : "1", 1, 0), envPtr); - TclStoreInt4AtPtr(CurrentOffset(envPtr) - pc2, - envPtr->codeStart + pc2 + 1); + TclFixupForwardJumpToHere(envPtr, &pc2); convert = 0; freePtr = jumpPtr; jumpPtr = jumpPtr->next; diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 6b4fa67..0fdbf01 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -48,7 +48,7 @@ InstructionDesc const tclInstructionTable[] = { /* Finish ByteCode execution and return stktop (top stack item) */ {"push1", 2, +1, 1, {OPERAND_LIT1}}, /* Push object at ByteCode objArray[op1] */ - {"push4", 5, +1, 1, {OPERAND_LIT4}}, + {"push", 5, +1, 1, {OPERAND_LIT4}}, /* Push object at ByteCode objArray[op4] */ {"pop", 1, -1, 0, {OPERAND_NONE}}, /* Pop the topmost stack object */ @@ -58,7 +58,7 @@ InstructionDesc const tclInstructionTable[] = { /* Concatenate the top op1 items and push result */ {"invokeStk1", 2, INT_MIN, 1, {OPERAND_UINT1}}, /* Invoke command named objv[0]; = */ - {"invokeStk4", 5, INT_MIN, 1, {OPERAND_UINT4}}, + {"invokeStk", 5, INT_MIN, 1, {OPERAND_UINT4}}, /* Invoke command named objv[0]; = */ {"evalStk", 1, 0, 0, {OPERAND_NONE}}, /* Evaluate command in stktop using Tcl_EvalObj. */ @@ -67,13 +67,13 @@ InstructionDesc const tclInstructionTable[] = { {"loadScalar1", 2, 1, 1, {OPERAND_LVT1}}, /* Load scalar variable at index op1 <= 255 in call frame */ - {"loadScalar4", 5, 1, 1, {OPERAND_LVT4}}, + {"loadScalar", 5, 1, 1, {OPERAND_LVT4}}, /* Load scalar variable at index op1 >= 256 in call frame */ {"loadScalarStk", 1, 0, 0, {OPERAND_NONE}}, /* Load scalar variable; scalar's name is stktop */ {"loadArray1", 2, 0, 1, {OPERAND_LVT1}}, /* Load array element; array at slot op1<=255, element is stktop */ - {"loadArray4", 5, 0, 1, {OPERAND_LVT4}}, + {"loadArray", 5, 0, 1, {OPERAND_LVT4}}, /* Load array element; array at slot op1 > 255, element is stktop */ {"loadArrayStk", 1, -1, 0, {OPERAND_NONE}}, /* Load array element; element is stktop, array name is stknext */ @@ -81,13 +81,13 @@ InstructionDesc const tclInstructionTable[] = { /* Load general variable; unparsed variable name is stktop */ {"storeScalar1", 2, 0, 1, {OPERAND_LVT1}}, /* Store scalar variable at op1<=255 in frame; value is stktop */ - {"storeScalar4", 5, 0, 1, {OPERAND_LVT4}}, + {"storeScalar", 5, 0, 1, {OPERAND_LVT4}}, /* Store scalar variable at op1 > 255 in frame; value is stktop */ {"storeScalarStk", 1, -1, 0, {OPERAND_NONE}}, /* Store scalar; value is stktop, scalar name is stknext */ {"storeArray1", 2, -1, 1, {OPERAND_LVT1}}, /* Store array element; array at op1<=255, value is top then elem */ - {"storeArray4", 5, -1, 1, {OPERAND_LVT4}}, + {"storeArray", 5, -1, 1, {OPERAND_LVT4}}, /* Store array element; array at op1>=256, value is top then elem */ {"storeArrayStk", 1, -2, 0, {OPERAND_NONE}}, /* Store array element; value is stktop, then elem, array names */ @@ -118,15 +118,15 @@ InstructionDesc const tclInstructionTable[] = { {"jump1", 2, 0, 1, {OPERAND_OFFSET1}}, /* Jump relative to (pc + op1) */ - {"jump4", 5, 0, 1, {OPERAND_OFFSET4}}, + {"jump", 5, 0, 1, {OPERAND_OFFSET4}}, /* Jump relative to (pc + op4) */ {"jumpTrue1", 2, -1, 1, {OPERAND_OFFSET1}}, /* Jump relative to (pc + op1) if stktop expr object is true */ - {"jumpTrue4", 5, -1, 1, {OPERAND_OFFSET4}}, + {"jumpTrue", 5, -1, 1, {OPERAND_OFFSET4}}, /* Jump relative to (pc + op4) if stktop expr object is true */ {"jumpFalse1", 2, -1, 1, {OPERAND_OFFSET1}}, /* Jump relative to (pc + op1) if stktop expr object is false */ - {"jumpFalse4", 5, -1, 1, {OPERAND_OFFSET4}}, + {"jumpFalse", 5, -1, 1, {OPERAND_OFFSET4}}, /* Jump relative to (pc + op4) if stktop expr object is false */ {"bitor", 1, -1, 0, {OPERAND_NONE}}, @@ -178,7 +178,7 @@ InstructionDesc const tclInstructionTable[] = { /* Skip to next iteration of closest enclosing loop; if none, return * TCL_CONTINUE code. */ - {"beginCatch4", 5, 0, 1, {OPERAND_UINT4}}, + {"beginCatch", 5, 0, 1, {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}}, @@ -211,11 +211,11 @@ InstructionDesc const tclInstructionTable[] = { {"appendScalar1", 2, 0, 1, {OPERAND_LVT1}}, /* Append scalar variable at op1<=255 in frame; value is stktop */ - {"appendScalar4", 5, 0, 1, {OPERAND_LVT4}}, + {"appendScalar", 5, 0, 1, {OPERAND_LVT4}}, /* Append scalar variable at op1 > 255 in frame; value is stktop */ {"appendArray1", 2, -1, 1, {OPERAND_LVT1}}, /* Append array element; array at op1<=255, value is top then elem */ - {"appendArray4", 5, -1, 1, {OPERAND_LVT4}}, + {"appendArray", 5, -1, 1, {OPERAND_LVT4}}, /* Append array element; array at op1>=256, value is top then elem */ {"appendArrayStk", 1, -2, 0, {OPERAND_NONE}}, /* Append array element; value is stktop, then elem, array names */ @@ -223,11 +223,11 @@ InstructionDesc const tclInstructionTable[] = { /* Append general variable; value is stktop, then unparsed name */ {"lappendScalar1", 2, 0, 1, {OPERAND_LVT1}}, /* Lappend scalar variable at op1<=255 in frame; value is stktop */ - {"lappendScalar4", 5, 0, 1, {OPERAND_LVT4}}, + {"lappendScalar", 5, 0, 1, {OPERAND_LVT4}}, /* Lappend scalar variable at op1 > 255 in frame; value is stktop */ {"lappendArray1", 2, -1, 1, {OPERAND_LVT1}}, /* Lappend array element; array at op1<=255, value is top then elem */ - {"lappendArray4", 5, -1, 1, {OPERAND_LVT4}}, + {"lappendArray", 5, -1, 1, {OPERAND_LVT4}}, /* Lappend array element; array at op1>=256, value is top then elem */ {"lappendArrayStk", 1, -2, 0, {OPERAND_NONE}}, /* Lappend array element; value is stktop, then elem, array names */ @@ -657,7 +657,7 @@ InstructionDesc const tclInstructionTable[] = { /* String Less or equal: push (stknext <= stktop) */ {"strge", 1, -1, 0, {OPERAND_NONE}}, /* String Greater or equal: push (stknext >= stktop) */ - {"lreplace4", 6, INT_MIN, 2, {OPERAND_UINT4, OPERAND_UINT1}}, + {"lreplace", 6, INT_MIN, 2, {OPERAND_UINT4, OPERAND_UINT1}}, /* Operands: number of arguments, flags * flags: Combination of TCL_LREPLACE4_* flags * Stack: ... listobj index1 ?index2? new1 ... newN => ... newlistobj @@ -672,11 +672,20 @@ InstructionDesc const tclInstructionTable[] = { /* Create constant. Variable name and value on stack. * Stack: ... varName value => ... */ - {"returnCodeBranch4", 1, -1, 0, {OPERAND_NONE}}, + {"returnCodeBranch", 1, -1, 0, {OPERAND_NONE}}, /* Jump to next instruction based on the return code on top of stack * ERROR: +1; RETURN: +6; BREAK: +11; CONTINUE: +16; * Other non-OK: +21 */ + {"incrScalar", 5, 0, 1, {OPERAND_LVT4}}, + /* Incr scalar at index op1 in frame; incr amount is stktop */ + {"incrArray", 5, -1, 1, {OPERAND_LVT4}}, + /* Incr array elem; arr at slot op1, amount is top then elem */ + {"incrScalarImm", 6, +1, 2, {OPERAND_LVT4, OPERAND_INT1}}, + /* Incr scalar at slot op1; amount is 2nd operand byte */ + {"incrArrayImm", 6, 0, 2, {OPERAND_LVT4, OPERAND_INT1}}, + /* Incr array elem; array at slot op1, elem is stktop, + * amount is 2nd operand byte */ {NULL, 0, 0, 0, {OPERAND_NONE}} }; @@ -1881,11 +1890,7 @@ TclCompileInvocation( TclEmitPush(objIdx, envPtr); } - if (wordIdx <= 255) { - TclEmitInvoke(envPtr, INST_INVOKE_STK1, wordIdx); - } else { - TclEmitInvoke(envPtr, INST_INVOKE_STK4, wordIdx); - } + TclEmitInvoke(envPtr, INST_INVOKE_STK4, wordIdx); TclCheckStackDepth(depth+1, envPtr); } @@ -2404,8 +2409,6 @@ TclCompileVarSubst( if (tokenPtr->numComponents == 1) { if (localVar < 0) { TclEmitOpcode(INST_LOAD_STK, envPtr); - } else if (localVar <= 255) { - TclEmitInstInt1(INST_LOAD_SCALAR1, localVar, envPtr); } else { TclEmitInstInt4(INST_LOAD_SCALAR4, localVar, envPtr); } @@ -2413,8 +2416,6 @@ TclCompileVarSubst( 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); } else { TclEmitInstInt4(INST_LOAD_ARRAY4, localVar, envPtr); } diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 6e07bbc..3e2b97d 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -534,6 +534,20 @@ typedef struct ByteCode { (codePtr) = irPtr ? (ByteCode*)irPtr->twoPtrValue.ptr1 : NULL; \ } while (0) +#ifdef ALLOW_DEPRECATED_OPCODES +#define DEPRECATED_OPCODE(name) \ + name +#elif defined(_MSC_VER) +#define DEPRECATED_OPCODE(name) \ + name [[deprecated]] +#elif defined(__GNUC__) || defined(__clang__) +#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 @@ -545,50 +559,50 @@ typedef struct ByteCode { enum TclInstruction { /* Opcodes 0 to 9 */ INST_DONE = 0, - INST_PUSH1, + DEPRECATED_OPCODE(INST_PUSH1), INST_PUSH4, INST_POP, INST_DUP, INST_STR_CONCAT1, - INST_INVOKE_STK1, + DEPRECATED_OPCODE(INST_INVOKE_STK1), INST_INVOKE_STK4, INST_EVAL_STK, INST_EXPR_STK, /* Opcodes 10 to 23 */ - INST_LOAD_SCALAR1, + DEPRECATED_OPCODE(INST_LOAD_SCALAR1), INST_LOAD_SCALAR4, INST_LOAD_SCALAR_STK, - INST_LOAD_ARRAY1, + DEPRECATED_OPCODE(INST_LOAD_ARRAY1), INST_LOAD_ARRAY4, INST_LOAD_ARRAY_STK, INST_LOAD_STK, - INST_STORE_SCALAR1, + DEPRECATED_OPCODE(INST_STORE_SCALAR1), INST_STORE_SCALAR4, INST_STORE_SCALAR_STK, - INST_STORE_ARRAY1, + DEPRECATED_OPCODE(INST_STORE_ARRAY1), INST_STORE_ARRAY4, INST_STORE_ARRAY_STK, INST_STORE_STK, /* Opcodes 24 to 33 */ - INST_INCR_SCALAR1, + DEPRECATED_OPCODE(INST_INCR_SCALAR1), INST_INCR_SCALAR_STK, - INST_INCR_ARRAY1, + DEPRECATED_OPCODE(INST_INCR_ARRAY1), INST_INCR_ARRAY_STK, INST_INCR_STK, - INST_INCR_SCALAR1_IMM, + DEPRECATED_OPCODE(INST_INCR_SCALAR1_IMM), INST_INCR_SCALAR_STK_IMM, - INST_INCR_ARRAY1_IMM, + DEPRECATED_OPCODE(INST_INCR_ARRAY1_IMM), INST_INCR_ARRAY_STK_IMM, INST_INCR_STK_IMM, /* Opcodes 34 to 39 */ - INST_JUMP1, + DEPRECATED_OPCODE(INST_JUMP1), INST_JUMP4, - INST_JUMP_TRUE1, + DEPRECATED_OPCODE(INST_JUMP_TRUE1), INST_JUMP_TRUE4, - INST_JUMP_FALSE1, + DEPRECATED_OPCODE(INST_JUMP_FALSE1), INST_JUMP_FALSE4, /* Opcodes 42 to 64 */ @@ -638,17 +652,17 @@ enum TclInstruction { INST_LIST_LENGTH, /* Opcodes 82 to 87 */ - INST_APPEND_SCALAR1, + DEPRECATED_OPCODE(INST_APPEND_SCALAR1), INST_APPEND_SCALAR4, - INST_APPEND_ARRAY1, + DEPRECATED_OPCODE(INST_APPEND_ARRAY1), INST_APPEND_ARRAY4, INST_APPEND_ARRAY_STK, INST_APPEND_STK, /* Opcodes 88 to 93 */ - INST_LAPPEND_SCALAR1, + DEPRECATED_OPCODE(INST_LAPPEND_SCALAR1), INST_LAPPEND_SCALAR4, - INST_LAPPEND_ARRAY1, + DEPRECATED_OPCODE(INST_LAPPEND_ARRAY1), INST_LAPPEND_ARRAY4, INST_LAPPEND_ARRAY_STK, INST_LAPPEND_STK, @@ -732,7 +746,7 @@ enum TclInstruction { /* For [subst] compilation */ INST_NOP, - INST_RETURN_CODE_BRANCH1, + DEPRECATED_OPCODE(INST_RETURN_CODE_BRANCH1), /* For [unset] compilation */ INST_UNSET_SCALAR, @@ -833,8 +847,12 @@ enum TclInstruction { INST_CONST_IMM, INST_CONST_STK, - /* Updated [subst] compilation */ + /* Updated [subst] and [incr] compilation */ INST_RETURN_CODE_BRANCH4, + INST_INCR_SCALAR4, + INST_INCR_ARRAY4, + INST_INCR_SCALAR4_IMM, + INST_INCR_ARRAY4_IMM, /* The last opcode */ LAST_INST_OPCODE @@ -1648,18 +1666,6 @@ TclUpdateStackReqs( TclPushVarName(i,v,e,f,l,sc) /* - * 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 Emit14Inst(nm,idx,envPtr) \ - if (idx <= 255) { \ - TclEmitInstInt1(nm##1,idx,envPtr); \ - } else { \ - TclEmitInstInt4(nm##4,idx,envPtr); \ - } - -/* * How to get an anonymous local variable (used for holding temporary values * off the stack) or a local simple scalar. */ diff --git a/generic/tclExecute.c b/generic/tclExecute.c index ce1b004..790f03d 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -16,6 +16,7 @@ */ #include "tclInt.h" +#define ALLOW_DEPRECATED_OPCODES #include "tclCompile.h" #include "tclOOInt.h" #include "tclTomMath.h" @@ -415,6 +416,13 @@ VarHashCreateVar( # define O2S(objPtr) #endif /* TCL_COMPILE_DEBUG */ +#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 + /* * DTrace instruction probe macros. */ @@ -2273,12 +2281,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_SCALAR4) { + goto instLoadScalar4; + } else if (inst == INST_PUSH4) { + 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) { /* @@ -2548,6 +2556,13 @@ TEBCresume( (void) POP_OBJECT(); goto abnormalReturn; + 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); + break; + case INST_PUSH4: objResultPtr = codePtr->objArrayPtr[TclGetUInt4AtPtr(pc+1)]; TRACE_WITH_OBJ(("%u => ", TclGetUInt4AtPtr(pc+1)), objResultPtr); @@ -2779,6 +2794,7 @@ TEBCresume( goto doInvocation; case INST_INVOKE_STK1: + DEPRECATED_OPCODE_MARK(INST_INVOKE_STK1); objc = TclGetUInt1AtPtr(pc+1); pcAdjustment = 2; @@ -2903,7 +2919,7 @@ TEBCresume( */ case INST_LOAD_SCALAR1: - instLoadScalar1: + DEPRECATED_OPCODE_MARK(INST_LOAD_SCALAR1); opnd = TclGetUInt1AtPtr(pc+1); varPtr = LOCAL(opnd); while (TclIsVarLink(varPtr)) { @@ -2926,6 +2942,7 @@ TEBCresume( goto doCallPtrGetVar; case INST_LOAD_SCALAR4: + instLoadScalar4: opnd = TclGetUInt4AtPtr(pc+1); varPtr = LOCAL(opnd); while (TclIsVarLink(varPtr)) { @@ -2953,6 +2970,7 @@ TEBCresume( goto doLoadArray; case INST_LOAD_ARRAY1: + DEPRECATED_OPCODE_MARK(INST_LOAD_ARRAY1); opnd = TclGetUInt1AtPtr(pc+1); pcAdjustment = 2; @@ -3058,6 +3076,7 @@ TEBCresume( goto doStoreArrayDirect; case INST_STORE_ARRAY1: + DEPRECATED_OPCODE_MARK(INST_STORE_ARRAY1); opnd = TclGetUInt1AtPtr(pc+1); pcAdjustment = 2; @@ -3090,6 +3109,7 @@ TEBCresume( goto doStoreScalarDirect; case INST_STORE_SCALAR1: + DEPRECATED_OPCODE_MARK(INST_STORE_SCALAR1); opnd = TclGetUInt1AtPtr(pc+1); pcAdjustment = 2; @@ -3198,6 +3218,7 @@ TEBCresume( goto doStoreArray; case INST_LAPPEND_ARRAY1: + DEPRECATED_OPCODE_MARK(INST_LAPPEND_ARRAY1); opnd = TclGetUInt1AtPtr(pc+1); pcAdjustment = 2; storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE @@ -3211,6 +3232,7 @@ TEBCresume( goto doStoreArray; case INST_APPEND_ARRAY1: + DEPRECATED_OPCODE_MARK(INST_APPEND_ARRAY1); opnd = TclGetUInt1AtPtr(pc+1); pcAdjustment = 2; storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); @@ -3245,6 +3267,7 @@ TEBCresume( goto doStoreScalar; case INST_LAPPEND_SCALAR1: + DEPRECATED_OPCODE_MARK(INST_LAPPEND_SCALAR1); opnd = TclGetUInt1AtPtr(pc+1); pcAdjustment = 2; storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE @@ -3258,6 +3281,7 @@ TEBCresume( goto doStoreScalar; case INST_APPEND_SCALAR1: + DEPRECATED_OPCODE_MARK(INST_APPEND_ARRAY1); opnd = TclGetUInt1AtPtr(pc+1); pcAdjustment = 2; storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); @@ -3486,9 +3510,11 @@ TEBCresume( incrPtr = POP_OBJECT(); switch (*pc) { 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; default: @@ -3496,6 +3522,20 @@ TEBCresume( goto doIncrStk; } + case INST_INCR_SCALAR4: + case INST_INCR_ARRAY4: + opnd = TclGetUInt4AtPtr(pc+1); + incrPtr = POP_OBJECT(); + pcAdjustment = 5; + switch (*pc) { + case INST_INCR_SCALAR4: + goto doIncrScalar; + case INST_INCR_ARRAY4: + goto doIncrArray; + default: + Tcl_Panic("unknown instruction"); + } + case INST_INCR_ARRAY_STK_IMM: case INST_INCR_SCALAR_STK_IMM: case INST_INCR_STK_IMM: @@ -3532,7 +3572,16 @@ TEBCresume( cleanup = ((part2Ptr == NULL)? 1 : 2); goto doIncrVar; + case INST_INCR_ARRAY4_IMM: + opnd = TclGetUInt4AtPtr(pc+1); + increment = TclGetInt1AtPtr(pc+5); + TclNewIntObj(incrPtr, increment); + Tcl_IncrRefCount(incrPtr); + pcAdjustment = 6; + goto doIncrArray; + case INST_INCR_ARRAY1_IMM: + DEPRECATED_OPCODE_MARK(INST_INCR_ARRAY1_IMM); opnd = TclGetUInt1AtPtr(pc+1); increment = TclGetInt1AtPtr(pc+2); TclNewIntObj(incrPtr, increment); @@ -3557,10 +3606,16 @@ TEBCresume( } goto doIncrVar; + case INST_INCR_SCALAR4_IMM: + opnd = TclGetUInt4AtPtr(pc+1); + increment = TclGetInt1AtPtr(pc+5); + pcAdjustment = 6; + goto doIncrScalarImm; case INST_INCR_SCALAR1_IMM: opnd = TclGetUInt1AtPtr(pc+1); increment = TclGetInt1AtPtr(pc+2); pcAdjustment = 3; + doIncrScalarImm: cleanup = 0; varPtr = LOCAL(opnd); while (TclIsVarLink(varPtr)) { @@ -4215,11 +4270,11 @@ TEBCresume( */ case INST_JUMP1: + DEPRECATED_OPCODE_MARK(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); @@ -4243,11 +4298,13 @@ TEBCresume( goto doCondJump; case INST_JUMP_FALSE1: + DEPRECATED_OPCODE_MARK(INST_JUMP_FALSE1); jmpOffset[0] = TclGetInt1AtPtr(pc+1); jmpOffset[1] = 2; goto doCondJump; case INST_JUMP_TRUE1: + DEPRECATED_OPCODE_MARK(INST_JUMP_TRUE1); jmpOffset[0] = 2; jmpOffset[1] = TclGetInt1AtPtr(pc+1); @@ -6739,6 +6796,7 @@ TEBCresume( case INST_RETURN_CODE_BRANCH1: { int code; + DEPRECATED_OPCODE_MARK(INST_RETURN_CODE_BRANCH1); if (TclGetIntFromObj(NULL, OBJ_AT_TOS, &code) != TCL_OK) { Tcl_Panic("INST_RETURN_CODE_BRANCH: TOS not a return code!"); } diff --git a/generic/tclOptimize.c b/generic/tclOptimize.c index 3f1a7ba..a885438 100644 --- a/generic/tclOptimize.c +++ b/generic/tclOptimize.c @@ -10,6 +10,7 @@ */ #include "tclInt.h" +#define ALLOW_DEPRECATED_OPCODES #include "tclCompile.h" #include @@ -289,7 +290,9 @@ ConvertZeroEffectToNOP( case INST_JUMP_FALSE1: case INST_JUMP_FALSE4: case INST_INCR_SCALAR1: + case INST_INCR_SCALAR4: case INST_INCR_ARRAY1: + case INST_INCR_ARRAY4: case INST_INCR_ARRAY_STK: case INST_INCR_SCALAR_STK: case INST_INCR_STK: -- cgit v0.12 From 229e7db6f099fc56569518ab5fb556dc387e7ace Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 18 Mar 2025 21:06:01 +0000 Subject: "Makefile.in" part was missing from previous commit. Use $@ in stead of ${LIB_FILE} --- unix/Makefile.in | 2 +- unix/configure | 2 +- unix/tcl.m4 | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/unix/Makefile.in b/unix/Makefile.in index c312fcd..9569b3b 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -812,7 +812,7 @@ ${LIB_FILE}: ${STUB_LIB_FILE} ${OBJS} ${TCL_ZIP_FILE} fi ${STUB_LIB_FILE}: ${STUB_LIB_OBJS} - @if [ "x${LIB_FILE}" = "xlibtcl${MAJOR_VERSION}.${MINOR_VERSION}.dll" ] ; then \ + @if [ "x${LIB_FILE}" = "xcygtcl${MAJOR_VERSION}.${MINOR_VERSION}.dll" ] ; then \ ( cd ${TOP_DIR}/win; ${MAKE} winextensions ); \ fi rm -f $@ diff --git a/unix/configure b/unix/configure index 9ec07b0..c22b465 100755 --- a/unix/configure +++ b/unix/configure @@ -5950,7 +5950,7 @@ fi ;; CYGWIN_*|MINGW32_*|MSYS_*) SHLIB_CFLAGS="-fno-common" - SHLIB_LD='${CC} -shared -Wl,--out-implib,$(patsubst cyg%.dll,lib%.dll.a,${LIB_FILE})' + SHLIB_LD='${CC} -shared -Wl,--out-implib,$(patsubst cyg%.dll,lib%.dll.a,$@)' SHLIB_SUFFIX=".dll" DL_OBJS="tclLoadDl.o" PLAT_OBJS='${CYGWIN_OBJS}' diff --git a/unix/tcl.m4 b/unix/tcl.m4 index 222b80f..92d0b27 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -1079,7 +1079,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ ;; CYGWIN_*|MINGW32_*|MSYS_*) SHLIB_CFLAGS="-fno-common" - SHLIB_LD='${CC} -shared -Wl,--out-implib,$(patsubst cyg%.dll,lib%.dll.a,${LIB_FILE})' + SHLIB_LD='${CC} -shared -Wl,--out-implib,$(patsubst cyg%.dll,lib%.dll.a,$[@])' SHLIB_SUFFIX=".dll" DL_OBJS="tclLoadDl.o" PLAT_OBJS='${CYGWIN_OBJS}' -- cgit v0.12 From 11b22d6cfc802bd582dccd73ad9e45b219e84005 Mon Sep 17 00:00:00 2001 From: stevel Date: Mon, 24 Mar 2025 09:25:03 +0000 Subject: Ticket [https://core.tcl-lang.org/tcl/tktview/010d8f3885642212cf2c65036dd4ad444e9f769e]. A fix for a panic if tclEpollNotfy PlatformEventsControl TclOSfstat returns -1 which it does when using a websocket to a browser and the browser page is refreshed. As per discussions with Jan and Donal the only thing we can do is return and hope it doesn't leak too much memory. --- unix/tclEpollNotfy.c | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/unix/tclEpollNotfy.c b/unix/tclEpollNotfy.c index db6ee13..29d41ca 100644 --- a/unix/tclEpollNotfy.c +++ b/unix/tclEpollNotfy.c @@ -223,10 +223,8 @@ PlatformEventsControl( */ if (TclOSfstat(filePtr->fd, &fdStat) == -1) { - Tcl_Panic("fstat: %s", strerror(errno)); - } - - if (epoll_ctl(tsdPtr->eventsFd, op, filePtr->fd, &newEvent) == -1) { + return; + } else if (epoll_ctl(tsdPtr->eventsFd, op, filePtr->fd, &newEvent) == -1) { switch (errno) { case EPERM: switch (op) { -- cgit v0.12 From 70087dd65987591b7a524b84b749f903def6c5d5 Mon Sep 17 00:00:00 2001 From: stevel Date: Mon, 24 Mar 2025 11:34:19 +0000 Subject: Added comments explaining the tclEpollNotfy.c fix --- unix/tclEpollNotfy.c | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/unix/tclEpollNotfy.c b/unix/tclEpollNotfy.c index 29d41ca..0138a00 100644 --- a/unix/tclEpollNotfy.c +++ b/unix/tclEpollNotfy.c @@ -223,6 +223,14 @@ PlatformEventsControl( */ if (TclOSfstat(filePtr->fd, &fdStat) == -1) { + /* + * The tclEpollNotfy PlatformEventsControl function panics if the TclOSfstat + * call returns -1, which occurs when using a websocket to a browser and the + * browser page is refreshed. It seems the fstat call isn't doing anything + * useful, in particular the contents of the statbuf aren't examined afterwards + * on success and at best it changes the panic message. Instead we avoid the + * panic at the cost of a memory leak. + */ return; } else if (epoll_ctl(tsdPtr->eventsFd, op, filePtr->fd, &newEvent) == -1) { switch (errno) { -- cgit v0.12 From 3093caddbcf2558278e13a1d2fd3cb11822de02d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 25 Mar 2025 16:08:15 +0000 Subject: Fix all (Windows) C4244 warnings in win/tclWin*.c files --- win/tclWinConsole.c | 8 ++++---- win/tclWinDde.c | 4 ++-- win/tclWinFCmd.c | 5 +++-- win/tclWinFile.c | 14 ++++++++------ win/tclWinPipe.c | 14 ++++++++------ win/tclWinReg.c | 6 +++--- win/tclWinSerial.c | 2 +- win/tclWinSock.c | 4 ++-- 8 files changed, 31 insertions(+), 26 deletions(-) diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index a077954..ce4f2b9 100644 --- a/win/tclWinConsole.c +++ b/win/tclWinConsole.c @@ -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) { @@ -1228,7 +1228,7 @@ ConsoleInputProc( } ReleaseSRWLockExclusive(&handleInfoPtr->lock); - return numRead; + return (int)numRead; } /* @@ -1354,7 +1354,7 @@ ConsoleOutputProc( } WakeConditionVariable(&handleInfoPtr->consoleThreadCV); ReleaseSRWLockExclusive(&handleInfoPtr->lock); - return numWritten; + return (int)numWritten; } /* diff --git a/win/tclWinDde.c b/win/tclWinDde.c index 49d2803..abec9b2 100644 --- a/win/tclWinDde.c +++ b/win/tclWinDde.c @@ -1297,8 +1297,8 @@ DdeObjCmd( }; int index, argIndex; - Tcl_Size length, i; - int flags = 0, result = TCL_OK, firstArg = 0; + Tcl_Size length, i, firstArg = 0; + int flags = 0, result = TCL_OK; HSZ ddeService = NULL, ddeTopic = NULL, ddeItem = NULL, ddeCookie = NULL; HDDEDATA ddeData = NULL, ddeItemData = NULL, ddeReturn; HCONV hConv = NULL; diff --git a/win/tclWinFCmd.c b/win/tclWinFCmd.c index 694be0d..723e8e9 100644 --- a/win/tclWinFCmd.c +++ b/win/tclWinFCmd.c @@ -1186,7 +1186,8 @@ TraverseWinTree( { DWORD sourceAttr; WCHAR *nativeSource, *nativeTarget, *nativeErrfile; - int result, found, sourceLen, targetLen = 0, oldSourceLen, oldTargetLen; + int result, found, sourceLen; + Tcl_Size oldSourceLen, oldTargetLen, targetLen = 0; HANDLE handle; WIN32_FIND_DATAW data; @@ -1976,7 +1977,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 76942c6..2203aef 100644 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -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; @@ -1424,7 +1425,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; @@ -2520,7 +2521,7 @@ TclpObjNormalizePath( TCL_UNUSED(Tcl_Interp *), 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. */ @@ -2528,6 +2529,7 @@ TclpObjNormalizePath( Tcl_Obj *temp = NULL; int isDrive = 1; Tcl_DString ds; /* Some workspace. */ + Tcl_Size nextCheckpoint = nextCheckpoint1; Tcl_DStringInit(&dsNorm); path = TclGetString(pathPtr); @@ -2681,7 +2683,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 @@ -2820,7 +2822,7 @@ TclpObjNormalizePath( Tcl_DecrRefCount(temp); } - return nextCheckpoint; + return (int)nextCheckpoint; } /* @@ -3091,7 +3093,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/tclWinPipe.c b/win/tclWinPipe.c index 1474567..2e96053 100644 --- a/win/tclWinPipe.c +++ b/win/tclWinPipe.c @@ -671,9 +671,10 @@ 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 @@ -689,7 +690,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 +702,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; } } @@ -1262,7 +1263,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; @@ -2735,7 +2737,7 @@ TclWinAddProcess( PipeInit(); procPtr->hProcess = hProcess; - procPtr->dwProcessId = id; + procPtr->dwProcessId = (int)id; Tcl_MutexLock(&pipeMutex); procPtr->nextPtr = procList; procList = procPtr; diff --git a/win/tclWinReg.c b/win/tclWinReg.c index e29556c..ae02210 100644 --- a/win/tclWinReg.c +++ b/win/tclWinReg.c @@ -730,7 +730,7 @@ GetValue( HKEY key; const char *valueName; const WCHAR *nativeValue; - DWORD result, length, type; + DWORD result, type, length; Tcl_DString data, buf; Tcl_Size len; @@ -770,7 +770,7 @@ GetValue( * HKEY_PERFORMANCE_DATA */ - length = Tcl_DStringLength(&data) * (2 / sizeof(WCHAR)); + length = (DWORD)(Tcl_DStringLength(&data) * (2 / sizeof(WCHAR))); Tcl_DStringSetLength(&data, length * sizeof(WCHAR)); result = RegQueryValueExW(key, nativeValue, NULL, &type, (BYTE *) Tcl_DStringValue(&data), &length); @@ -1443,7 +1443,7 @@ AppendSystemError( Tcl_Interp *interp, /* Current interpreter. */ DWORD error) /* Result code from error. */ { - int length; + Tcl_Size length; WCHAR *tMsgPtr, **tMsgPtrPtr = &tMsgPtr; const char *msg; char id[TCL_INTEGER_SPACE], msgBuf[24 + TCL_INTEGER_SPACE]; diff --git a/win/tclWinSerial.c b/win/tclWinSerial.c index 690183c..37ee79a 100644 --- a/win/tclWinSerial.c +++ b/win/tclWinSerial.c @@ -1795,7 +1795,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 29f1737..6771c39 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -392,7 +392,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))); } @@ -3054,7 +3054,7 @@ SocketThread( SetEvent(tsdPtr->readyEvent); - return msg.wParam; + return (DWORD)msg.wParam; } /* -- cgit v0.12 From c21651adee499ae7cce6596e19c7f63357200b0b Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 28 Mar 2025 15:25:12 +0000 Subject: Many changes to basic opcode issuing to eliminate most 1-byte args. Not yet fully working... --- generic/tclAssembly.c | 176 +++------ generic/tclCompCmds.c | 769 ++++++++++++++++++------------------- generic/tclCompCmdsGR.c | 320 ++++++++-------- generic/tclCompCmdsSZ.c | 981 +++++++++++++++++++++++------------------------ generic/tclCompExpr.c | 8 +- generic/tclCompile.c | 173 +++++---- generic/tclCompile.h | 159 +++++--- generic/tclDisassemble.c | 45 ++- generic/tclExecute.c | 154 ++++---- generic/tclOptimize.c | 38 +- 10 files changed, 1415 insertions(+), 1408 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 6e3708c..427e3a4 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -30,6 +30,7 @@ */ #include "tclInt.h" +#define ALLOW_DEPRECATED_OPCODES #include "tclCompile.h" #include "tclOOInt.h" #include @@ -137,7 +138,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 @@ -168,12 +169,10 @@ 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_LVT4_SINT1, /* One 4-byte operand that references a local + 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 */ @@ -184,7 +183,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 */ @@ -247,8 +246,6 @@ 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); @@ -274,7 +271,7 @@ static void DeleteMirrorJumpTable(JumptableInfo* jtPtr); static void FillInJumpOffsets(AssemblyEnv*); static int CreateMirrorJumpTable(AssemblyEnv* assemEnvPtr, Tcl_Obj* jumpTable); -static size_t FindLocalVar(AssemblyEnv* envPtr, +static size_t FindLocalVar(AssemblyEnv* envPtr, Tcl_Token** tokenPtrPtr); static int FinishAssembly(AssemblyEnv*); static void FreeAssemblyEnv(AssemblyEnv*); @@ -332,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, INST_APPEND_SCALAR, 1, 1}, + {"appendArray", ASSEM_LVT, 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}, @@ -357,16 +351,15 @@ 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}, {"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}, {"dictSet", ASSEM_DICT_SET, INST_DICT_SET, INT_MIN,1}, {"dictUnset", ASSEM_DICT_UNSET, INST_DICT_UNSET, INT_MIN,1}, @@ -376,8 +369,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}, @@ -385,39 +378,33 @@ 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_LVT4, INST_INCR_SCALAR4, 1, 1}, - {"incrArray", ASSEM_LVT4, INST_INCR_ARRAY4, 2, 1}, - {"incrArrayImm", ASSEM_LVT4_SINT1, - INST_INCR_ARRAY4_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_LVT4_SINT1, - INST_INCR_SCALAR4_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_JUMP4, 0, 0}, + {"invokeStk", ASSEM_INVOKE, INST_INVOKE_STK, INT_MIN,1}, + {"jump", ASSEM_JUMP, INST_JUMP, 0, 0}, // For legacy code - {"jump4", ASSEM_JUMP, INST_JUMP4, 0, 0}, - {"jumpFalse", ASSEM_JUMP, INST_JUMP_FALSE4, 1, 0}, + {"jump4", ASSEM_JUMP, INST_JUMP, 0, 0}, + {"jumpFalse", ASSEM_JUMP, INST_JUMP_FALSE, 1, 0}, // For legacy code - {"jumpFalse4", ASSEM_JUMP, INST_JUMP_FALSE4, 1, 0}, + {"jumpFalse4", ASSEM_JUMP, INST_JUMP_FALSE, 1, 0}, {"jumpTable", ASSEM_JUMPTABLE,INST_JUMP_TABLE, 1, 0}, - {"jumpTrue", ASSEM_JUMP, INST_JUMP_TRUE4, 1, 0}, + {"jumpTrue", ASSEM_JUMP, INST_JUMP_TRUE, 1, 0}, // For legacy code - {"jumpTrue4", ASSEM_JUMP, INST_JUMP_TRUE4, 1, 0}, + {"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, INST_LAPPEND_SCALAR, 1, 1}, + {"lappendArray", ASSEM_LVT, 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 +418,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, INST_LOAD_SCALAR, 0, 1}, + {"loadArray", ASSEM_LVT, 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 +431,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 +444,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, INST_STORE_SCALAR, 1, 1}, + {"storeArray", ASSEM_LVT, 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}, @@ -495,13 +478,13 @@ static const TalInstDesc TalInstructionTable[] = { {"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} @@ -516,8 +499,8 @@ 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_PUSH1, INST_PUSH, INST_POP, INST_DUP, /* 1-4 */ + INST_JUMP1, INST_JUMP, /* 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 */ @@ -716,45 +699,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 @@ -1308,7 +1252,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: @@ -1352,7 +1296,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; @@ -1480,7 +1424,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,7 +1439,7 @@ AssembleOneLine( goto cleanup; } - BBEmitInst1or4(assemEnvPtr, tblIdx, opnd, opnd); + BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd); break; case ASSEM_JUMP: @@ -1621,19 +1565,7 @@ 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_LVT4_SINT1: + case ASSEM_LVT_SINT1: if (parsePtr->numWords != 3) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "varname imm8"); goto cleanup; @@ -1648,7 +1580,7 @@ AssembleOneLine( TclEmitInt1(opnd, envPtr); break; - case ASSEM_LVT4: + case ASSEM_LVT: if (parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "varname"); goto cleanup; @@ -1707,7 +1639,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; @@ -3547,7 +3479,7 @@ StackCheckExit( * Assumes that 'push' is at slot 0 in TalInstructionTable. */ - BBEmitInst1or4(assemEnvPtr, 0, litIndex, 0); + BBEmitInstInt4(assemEnvPtr, 0, litIndex, 0); ++depth; } @@ -4170,13 +4102,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 + diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index ac12493..70a2603 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -14,7 +14,7 @@ */ #include "tclInt.h" -#include "tclCompile.h" +#include "tclCompUtils.h" #include /* @@ -168,26 +168,26 @@ TclCompileAppendCmd( * each argument. */ - valueTokenPtr = TokenAfter(varTokenPtr); - CompileWord(envPtr, valueTokenPtr, interp, 2); + valueTokenPtr = TokenAfter(varTokenPtr); + CompileWord(envPtr, valueTokenPtr, interp, 2); /* * Emit instructions to set/get the variable. */ - if (isScalar) { - if (localIndex < 0) { - TclEmitOpcode(INST_APPEND_STK, envPtr); - } else { - TclEmitInstInt4(INST_APPEND_SCALAR4, localIndex, envPtr); - } + if (isScalar) { + if (localIndex < 0) { + OP( APPEND_STK); } else { - if (localIndex < 0) { - TclEmitOpcode(INST_APPEND_ARRAY_STK, envPtr); - } else { - TclEmitInstInt4(INST_APPEND_ARRAY4, localIndex, envPtr); - } + OP4( APPEND_SCALAR, localIndex); } + } else { + if (localIndex < 0) { + OP( APPEND_ARRAY_STK); + } else { + OP4( APPEND_ARRAY, localIndex); + } + } return TCL_OK; @@ -214,11 +214,11 @@ TclCompileAppendCmd( CompileWord(envPtr, valueTokenPtr, interp, i); valueTokenPtr = TokenAfter(valueTokenPtr); } - TclEmitInstInt4( INST_REVERSE, numWords-2, envPtr); + OP4( REVERSE, numWords - 2); for (i = 2 ; i < numWords ;) { - TclEmitInstInt4( INST_APPEND_SCALAR4, localIndex, envPtr); + OP4( APPEND_SCALAR, localIndex); if (++i < numWords) { - TclEmitOpcode(INST_POP, envPtr); + OP( POP); } } @@ -267,9 +267,9 @@ TclCompileArrayExistsCmd( } 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; } @@ -289,10 +289,10 @@ TclCompileArraySetCmd( int isDataLiteral, isDataValid, isDataEven; Tcl_Size len; int keyVar, valVar, infoIndex; - int fwd, offsetBack, offsetFwd; + int offsetBack; Tcl_Obj *literalObj; ForeachInfo *infoPtr; - JumpFixup arrayMade; + int arrayMade; if (parsePtr->numWords != 3) { return TCL_ERROR; @@ -320,10 +320,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; * */ @@ -354,25 +353,25 @@ TclCompileArraySetCmd( if (isDataEven && len == 0) { if (localIndex >= 0) { - JumpFixup haveArray; - TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr); - TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, &haveArray); - TclEmitInstInt4(INST_ARRAY_MAKE_IMM, localIndex, envPtr); - TclFixupForwardJumpToHere(envPtr, &haveArray); + int haveArray; + OP4( ARRAY_EXISTS_IMM, localIndex); + FWDJUMP( JUMP_TRUE, haveArray); + OP4( ARRAY_MAKE_IMM, localIndex); + FWDLABEL( haveArray); } else { - JumpFixup haveArray, arrayMade; - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_ARRAY_EXISTS_STK, envPtr); - TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, &haveArray); - TclEmitOpcode( INST_ARRAY_MAKE_STK, envPtr); - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &arrayMade); + int 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); - TclFixupForwardJumpToHere(envPtr, &haveArray); - TclEmitOpcode( INST_POP, envPtr); - TclFixupForwardJumpToHere(envPtr, &arrayMade); + FWDLABEL( haveArray); + OP( POP); + FWDLABEL( arrayMade); } - PushStringLiteral(envPtr, ""); + PUSH( ""); goto done; } @@ -384,10 +383,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"); + OP4( REVERSE, 2); + OP4( UPVAR, localIndex); + OP( POP); } /* @@ -397,9 +396,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; @@ -409,10 +410,10 @@ TclCompileArraySetCmd( * Start issuing instructions to write to the array. */ - TclEmitInstInt4( INST_ARRAY_EXISTS_IMM, localIndex, envPtr); - TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, &arrayMade); - TclEmitInstInt4( INST_ARRAY_MAKE_IMM, localIndex, envPtr); - TclFixupForwardJumpToHere(envPtr, &arrayMade); + OP4( ARRAY_EXISTS_IMM, localIndex); + FWDJUMP( JUMP_TRUE, arrayMade); + OP4( ARRAY_MAKE_IMM, localIndex); + FWDLABEL( arrayMade); CompileWord(envPtr, dataTokenPtr, interp, 2); if (!isDataLiteral || !isDataValid) { @@ -423,33 +424,32 @@ TclCompileArraySetCmd( * use-case with [array set]). */ - JumpFixup ok; - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_LIST_LENGTH, envPtr); - PushStringLiteral(envPtr, "1"); - TclEmitOpcode( INST_BITAND, envPtr); - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &ok); - 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); + int 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); TclAdjustStackDepth(-1, envPtr); - TclFixupForwardJumpToHere(envPtr, &ok); + FWDLABEL( ok); } - TclEmitInstInt4( INST_FOREACH_START, infoIndex, envPtr); + OP4( FOREACH_START, infoIndex); offsetBack = CurrentOffset(envPtr); - TclEmitInstInt4( INST_LOAD_SCALAR4, keyVar, envPtr); - TclEmitInstInt4( INST_LOAD_SCALAR4, valVar, envPtr); - TclEmitInstInt4( INST_STORE_ARRAY4, localIndex, envPtr); - TclEmitOpcode( INST_POP, envPtr); + 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); + OP( FOREACH_STEP); + OP( FOREACH_END); TclAdjustStackDepth(-3, envPtr); - PushStringLiteral(envPtr, ""); + PUSH( ""); - done: + done: Tcl_DecrRefCount(literalObj); return code; } @@ -466,6 +466,7 @@ TclCompileArrayUnsetCmd( DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); int isScalar, localIndex; + int noSuchArray, end; if (parsePtr->numWords != 2) { return TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr); @@ -478,26 +479,23 @@ TclCompileArrayUnsetCmd( } if (localIndex >= 0) { - JumpFixup end; - TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr); - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &end); - TclEmitInstInt1(INST_UNSET_SCALAR, 1, envPtr); - TclEmitInt4( localIndex, envPtr); - TclFixupForwardJumpToHere(envPtr, &end); + OP4( ARRAY_EXISTS_IMM, localIndex); + FWDJUMP( JUMP_FALSE, end); + OP14( UNSET_SCALAR, 1, localIndex); + FWDLABEL( end); } else { - JumpFixup noSuchArray, end; - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_ARRAY_EXISTS_STK, envPtr); - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &noSuchArray); - TclEmitInstInt1(INST_UNSET_STK, 1, envPtr); - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &end); + 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); - TclFixupForwardJumpToHere(envPtr, &noSuchArray); - TclEmitOpcode( INST_POP, envPtr); - TclFixupForwardJumpToHere(envPtr, &end); + FWDLABEL( noSuchArray); + OP( POP); + FWDLABEL( end); } - PushStringLiteral(envPtr, ""); + PUSH( ""); return TCL_OK; } @@ -551,7 +549,7 @@ TclCompileBreakCmd( * Emit a real break. */ - TclEmitOpcode(INST_BREAK, envPtr); + OP( BREAK); } TclAdjustStackDepth(1, envPtr); @@ -585,9 +583,8 @@ TclCompileCatchCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ - JumpFixup jumpFixup; Tcl_Token *cmdTokenPtr, *resultNameTokenPtr, *optsNameTokenPtr; - int resultIndex, optsIndex, range, dropScript = 0; + int resultIndex, optsIndex, range, dropScript = 0, haveResultAndCode; int depth = TclGetStackDepth(envPtr); /* @@ -651,22 +648,23 @@ TclCompileCatchCmd( range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); 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); + 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); + OP4( REVERSE, 2); + OP( POP); } - ExceptionRangeEnds(envPtr, range); /* * Emit the "no errors" epilogue: push "0" (TCL_OK) as the catch result, @@ -674,8 +672,8 @@ TclCompileCatchCmd( */ TclCheckStackDepth(depth+1, envPtr); - PushStringLiteral(envPtr, "0"); - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); + PUSH( "0"); + FWDJUMP( JUMP, haveResultAndCode); /* * Emit the "error case" epilogue. Push the interpreter result and the @@ -686,16 +684,16 @@ TclCompileCatchCmd( 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_RESULT); + OP( PUSH_RETURN_CODE); /* Stack at this point on both branches: result returnCode */ - TclFixupForwardJumpToHere(envPtr, &jumpFixup); + FWDLABEL( haveResultAndCode); /* * Push the return options if the caller wants them. This needs to happen @@ -703,14 +701,14 @@ TclCompileCatchCmd( */ if (optsIndex != -1) { - TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); + 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 @@ -718,8 +716,8 @@ TclCompileCatchCmd( */ if (optsIndex != -1) { - TclEmitInstInt4( INST_STORE_SCALAR4, optsIndex, envPtr); - TclEmitOpcode( INST_POP, envPtr); + OP4( STORE_SCALAR, optsIndex); + OP( POP); } /* @@ -728,11 +726,11 @@ TclCompileCatchCmd( * Reverse the stack to store the result. */ - TclEmitInstInt4( INST_REVERSE, 2, envPtr); + OP4( REVERSE, 2); if (resultIndex != -1) { - TclEmitInstInt4(INST_STORE_SCALAR4, resultIndex, envPtr); + OP4( STORE_SCALAR, resultIndex); } - TclEmitOpcode( INST_POP, envPtr); + OP( POP); TclCheckStackDepth(depth+1, envPtr); return TCL_OK; @@ -770,7 +768,7 @@ TclCompileClockClicksCmd( /* * No args */ - TclEmitInstInt1(INST_CLOCK_READ, 0, envPtr); + OP1( CLOCK_READ, 0); break; case 2: /* @@ -783,15 +781,14 @@ TclCompileClockClicksCmd( return TCL_ERROR; } else if (!strncmp(tokenPtr[1].start, "-microseconds", tokenPtr[1].size)) { - TclEmitInstInt1(INST_CLOCK_READ, 1, envPtr); - break; + OP1( CLOCK_READ, 1); } else if (!strncmp(tokenPtr[1].start, "-milliseconds", tokenPtr[1].size)) { - TclEmitInstInt1(INST_CLOCK_READ, 2, envPtr); - break; + OP1( CLOCK_READ, 2); } else { return TCL_ERROR; } + break; default: return TCL_ERROR; } @@ -830,8 +827,7 @@ TclCompileClockReadingCmd( return TCL_ERROR; } - TclEmitInstInt1(INST_CLOCK_READ, PTR2INT(cmdPtr->objClientData), envPtr); - + OP1( CLOCK_READ, PTR2INT(cmdPtr->objClientData)); return TCL_OK; } @@ -872,7 +868,7 @@ TclCompileConcatCmd( * [concat] without arguments just pushes an empty object. */ - PushStringLiteral(envPtr, ""); + PUSH( ""); return TCL_OK; } @@ -916,8 +912,7 @@ TclCompileConcatCmd( CompileWord(envPtr, tokenPtr, interp, i); } - TclEmitInstInt4( INST_CONCAT_STK, i-1, envPtr); - + OP4( CONCAT_STK, i - 1); return TCL_OK; } @@ -987,15 +982,15 @@ TclCompileConstCmd( CompileWord(envPtr, valueTokenPtr, interp, 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; } @@ -1054,7 +1049,7 @@ TclCompileContinueCmd( * Emit a real continue. */ - TclEmitOpcode(INST_CONTINUE, envPtr); + OP( CONTINUE); } TclAdjustStackDepth(1, envPtr); @@ -1089,14 +1084,14 @@ TclCompileDictSetCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - int i, dictVarIndex; + int i, dictVarIndex, numWords = (int) parsePtr->numWords; Tcl_Token *varTokenPtr; /* * There must be at least one argument after the command. */ - if ((int)parsePtr->numWords < 4) { + if (numWords < 4) { return TCL_ERROR; } @@ -1117,7 +1112,7 @@ TclCompileDictSetCmd( */ tokenPtr = TokenAfter(varTokenPtr); - for (i=2 ; i< (int)parsePtr->numWords ; i++) { + for (i=2 ; inumWords-3, envPtr); - TclEmitInt4( dictVarIndex, envPtr); + OP44( DICT_SET, numWords - 3, dictVarIndex); TclAdjustStackDepth(-1, envPtr); return TCL_OK; } @@ -1200,8 +1194,7 @@ TclCompileDictIncrCmd( */ CompileWord(envPtr, keyTokenPtr, interp, 2); - TclEmitInstInt4( INST_DICT_INCR_IMM, incrAmount, envPtr); - TclEmitInt4( dictVarIndex, envPtr); + OP44( DICT_INCR_IMM, incrAmount, dictVarIndex); return TCL_OK; } @@ -1215,7 +1208,7 @@ TclCompileDictGetCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - int i; + int i, numWords = (int) parsePtr->numWords; /* * There must be at least two arguments after the command (the single-arg @@ -1223,7 +1216,7 @@ TclCompileDictGetCmd( */ /* TODO: Consider support for compiling expanded args. */ - if ((int)parsePtr->numWords < 3) { + if (numWords < 3) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -1232,11 +1225,11 @@ TclCompileDictGetCmd( * Only compile this because we need INST_DICT_GET anyway. */ - for (i=1 ; i<(int)parsePtr->numWords ; i++) { + for (i=1 ; inumWords-2, envPtr); + OP4( DICT_GET, numWords - 2); TclAdjustStackDepth(-1, envPtr); return TCL_OK; } @@ -1251,23 +1244,23 @@ TclCompileDictGetWithDefaultCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - int i; + int i, numWords = (int) 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) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); - for (i=1 ; i<(int)parsePtr->numWords ; i++) { + for (i=1 ; inumWords-3, envPtr); + OP4( DICT_GET_DEF, numWords - 3); TclAdjustStackDepth(-2, envPtr); return TCL_OK; } @@ -1282,7 +1275,7 @@ TclCompileDictExistsCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - int i; + int i, numWords = (int) parsePtr->numWords; /* * There must be at least two arguments after the command (the single-arg @@ -1290,7 +1283,7 @@ TclCompileDictExistsCmd( */ /* TODO: Consider support for compiling expanded args. */ - if ((int)parsePtr->numWords < 3) { + if (numWords < 3) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -1299,11 +1292,11 @@ TclCompileDictExistsCmd( * Now we do the code generation. */ - for (i=1 ; i<(int)parsePtr->numWords ; i++) { + for (i=1 ; inumWords-2, envPtr); + OP4( DICT_EXISTS, numWords - 2); TclAdjustStackDepth(-1, envPtr); return TCL_OK; } @@ -1319,7 +1312,7 @@ TclCompileDictUnsetCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - int i, dictVarIndex; + int i, dictVarIndex, numWords = (int) parsePtr->numWords; /* * There must be at least one argument after the variable name for us to @@ -1327,7 +1320,7 @@ TclCompileDictUnsetCmd( */ /* TODO: Consider support for compiling expanded args. */ - if ((int)parsePtr->numWords < 3) { + if (numWords < 3) { return TCL_ERROR; } @@ -1347,7 +1340,7 @@ TclCompileDictUnsetCmd( * Remaining words (the key path) can be handled normally. */ - for (i=2 ; i<(int)parsePtr->numWords ; i++) { + for (i=2 ; inumWords-2, envPtr); - TclEmitInt4( dictVarIndex, envPtr); + OP44( DICT_UNSET, numWords - 2, dictVarIndex); return TCL_OK; } @@ -1418,8 +1410,8 @@ TclCompileDictCreateCmd( bytes = TclGetStringFromObj(dictObj, &len); PushLiteral(envPtr, bytes, len); - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_DICT_VERIFY, envPtr); + OP( DUP); + OP( DICT_VERIFY); Tcl_DecrRefCount(dictObj); return TCL_OK; @@ -1435,23 +1427,21 @@ TclCompileDictCreateCmd( return TclCompileBasicMin0ArgCmd(interp, parsePtr, cmdPtr, envPtr); } - PushStringLiteral(envPtr, ""); - TclEmitInstInt4( INST_STORE_SCALAR4, worker, envPtr); - TclEmitOpcode( INST_POP, envPtr); + PUSH( ""); + OP4( STORE_SCALAR, worker); + OP( POP); 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); + OP44( DICT_SET, 1, worker); TclAdjustStackDepth(-1, envPtr); - TclEmitOpcode( INST_POP, envPtr); + OP( POP); } - TclEmitInstInt4( INST_LOAD_SCALAR4, worker, envPtr); - TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); - TclEmitInt4( worker, envPtr); + OP4( LOAD_SCALAR, worker); + OP14( UNSET_SCALAR, 0, worker); return TCL_OK; } @@ -1466,8 +1456,7 @@ TclCompileDictMergeCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - int i, workerIndex, infoIndex, outLoop; - JumpFixup end; + int i, workerIndex, infoIndex, outLoop, end; /* * Deal with some special edge cases. Note that in the case with one @@ -1476,13 +1465,13 @@ TclCompileDictMergeCmd( /* TODO: Consider support for compiling expanded args. (less likely) */ if ((int)parsePtr->numWords < 2) { - PushStringLiteral(envPtr, ""); + PUSH( ""); return TCL_OK; } else if (parsePtr->numWords == 2) { tokenPtr = TokenAfter(parsePtr->tokenPtr); CompileWord(envPtr, tokenPtr, interp, 1); - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_DICT_VERIFY, envPtr); + OP( DUP); + OP( DICT_VERIFY); return TCL_OK; } @@ -1505,56 +1494,51 @@ TclCompileDictMergeCmd( tokenPtr = TokenAfter(parsePtr->tokenPtr); CompileWord(envPtr, tokenPtr, interp, 1); - TclEmitOpcode( INST_DUP, envPtr); - TclEmitOpcode( INST_DICT_VERIFY, envPtr); - TclEmitInstInt4( INST_STORE_SCALAR4, workerIndex,envPtr); - TclEmitOpcode( INST_POP, envPtr); + OP( DUP); + OP( DICT_VERIFY); + OP4( STORE_SCALAR, workerIndex); + OP( POP); /* * 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++) { - Tcl_Size haveNext; - JumpFixup noNext; - /* - * Get the dictionary, and merge its pairs into the first dict (using - * a small loop). - */ + OP4( BEGIN_CATCH, outLoop); + CATCH_RANGE(outLoop) { + for (i=2 ; i<(int)parsePtr->numWords ; i++) { + int haveNext, noNext; + /* + * Get the dictionary, and merge its pairs into the first dict (using + * a small loop). + */ - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, i); - TclEmitInstInt4( INST_DICT_FIRST, infoIndex, envPtr); - TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, &noNext); - haveNext = CurrentOffset(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); - TclEmitInstInt4( INST_JUMP_FALSE4, haveNext - CurrentOffset(envPtr), - envPtr); - TclFixupForwardJumpToHere(envPtr, &noNext); - TclEmitOpcode( INST_POP, envPtr); - TclEmitOpcode( INST_POP, envPtr); - TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); - TclEmitInt4( infoIndex, envPtr); + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, i); + OP4( DICT_FIRST, infoIndex); + FWDJUMP( JUMP_TRUE, noNext); + BACKLABEL( haveNext); + OP4( REVERSE, 2); + OP44( DICT_SET, 1, workerIndex); + TclAdjustStackDepth(-1, envPtr); + OP( POP); + OP4( DICT_NEXT, infoIndex); + BACKJUMP( JUMP_FALSE, haveNext); + FWDLABEL( noNext); + OP( POP); + OP( POP); + OP14( UNSET_SCALAR, 0, infoIndex); + } } - ExceptionRangeEnds(envPtr, outLoop); - TclEmitOpcode( INST_END_CATCH, envPtr); + OP( END_CATCH); /* * Clean up any state left over. */ - TclEmitInstInt4( INST_LOAD_SCALAR4, workerIndex, envPtr); - TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); - TclEmitInt4( workerIndex, envPtr); - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &end); + OP4( LOAD_SCALAR, workerIndex); + OP14( UNSET_SCALAR, 0, workerIndex); + FWDJUMP( JUMP, end); /* * If an exception happens when starting to iterate over the second (and @@ -1563,15 +1547,13 @@ TclCompileDictMergeCmd( 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); - TclFixupForwardJumpToHere(envPtr, &end); + OP( PUSH_RETURN_OPTIONS); + OP( PUSH_RESULT); + OP( END_CATCH); + OP14( UNSET_SCALAR, 0, workerIndex); + OP14( UNSET_SCALAR, 0, infoIndex); + INVOKE( RETURN_STK); + FWDLABEL( end); return TCL_OK; } @@ -1616,10 +1598,8 @@ CompileDictEachCmd( DefineLineInformation; /* TIP #280 */ Tcl_Token *varsTokenPtr, *dictTokenPtr, *bodyTokenPtr; int keyVarIndex, valueVarIndex, nameChars, loopRange, catchRange; - int infoIndex, jumpDisplacement, bodyTargetOffset, emptyTargetOffset; - JumpFixup emptyTarget, endTarget; + int infoIndex, bodyTargetOffset, emptyTarget, endTarget; Tcl_Size numVars; - int endTargetOffset; int collectVar = -1; /* Index of temp var holding the result * dict. */ const char **argv; @@ -1701,9 +1681,9 @@ CompileDictEachCmd( */ if (collect == TCL_EACH_COLLECT) { - PushStringLiteral(envPtr, ""); - TclEmitInstInt4(INST_STORE_SCALAR4, collectVar, envPtr); - TclEmitOpcode( INST_POP, envPtr); + PUSH( ""); + OP4( STORE_SCALAR, collectVar); + OP( POP); } /* @@ -1719,49 +1699,48 @@ CompileDictEachCmd( */ catchRange = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); - TclEmitInstInt4( INST_BEGIN_CATCH4, catchRange, envPtr); + OP4( BEGIN_CATCH, catchRange); ExceptionRangeStarts(envPtr, catchRange); - TclEmitInstInt4( INST_DICT_FIRST, infoIndex, envPtr); - TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, &emptyTarget); + OP4( DICT_FIRST, infoIndex); + FWDJUMP( JUMP_TRUE, emptyTarget); /* * Inside the iteration, write the loop variables. */ - bodyTargetOffset = CurrentOffset(envPtr); - TclEmitInstInt4( INST_STORE_SCALAR4, keyVarIndex, envPtr); - TclEmitOpcode( INST_POP, envPtr); - TclEmitInstInt4( INST_STORE_SCALAR4, valueVarIndex, envPtr); - TclEmitOpcode( INST_POP, envPtr); + BACKLABEL(bodyTargetOffset); + OP4( STORE_SCALAR, keyVarIndex); + OP( POP); + OP4( STORE_SCALAR, valueVarIndex); + OP( POP); /* * Set up the loop exception targets. */ loopRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); - ExceptionRangeStarts(envPtr, loopRange); /* * Compile the loop body itself. It should be stack-neutral. */ - BODY(bodyTokenPtr, 3); - if (collect == TCL_EACH_COLLECT) { - TclEmitInstInt4(INST_LOAD_SCALAR4, 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); + OP4( OVER, 1); + OP44( DICT_SET, 1, collectVar); + TclAdjustStackDepth(-1, envPtr); + OP( POP); + } + OP( POP); } - TclEmitOpcode( INST_POP, envPtr); /* * Both exception target ranges (error and loop) end here. */ - ExceptionRangeEnds(envPtr, loopRange); ExceptionRangeEnds(envPtr, catchRange); /* @@ -1771,10 +1750,9 @@ CompileDictEachCmd( */ ExceptionRangeTarget(envPtr, loopRange, continueOffset); - TclEmitInstInt4( INST_DICT_NEXT, infoIndex, envPtr); - jumpDisplacement = bodyTargetOffset - CurrentOffset(envPtr); - TclEmitInstInt4( INST_JUMP_FALSE4, jumpDisplacement, envPtr); - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &endTarget); + OP4( DICT_NEXT, infoIndex); + BACKJUMP( JUMP_FALSE, bodyTargetOffset); + FWDJUMP( JUMP, endTarget); /* * Error handler "finally" clause, which force-terminates the iteration @@ -1783,16 +1761,14 @@ CompileDictEachCmd( 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); + 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 @@ -1800,13 +1776,13 @@ CompileDictEachCmd( * easy!) Note that we skip the END_CATCH. [Bug 1382528] */ - TclFixupForwardJumpToHere(envPtr, &emptyTarget); - TclFixupForwardJumpToHere(envPtr, &endTarget); - TclEmitOpcode( INST_POP, envPtr); - TclEmitOpcode( INST_POP, envPtr); + FWDLABEL( emptyTarget); + FWDLABEL( endTarget); + OP( POP); + OP( POP); ExceptionRangeTarget(envPtr, loopRange, breakOffset); TclFinalizeLoopExceptionRange(envPtr, loopRange); - TclEmitOpcode( INST_END_CATCH, envPtr); + OP( END_CATCH); /* * Final stage of the command (normal case) is that we push an empty @@ -1814,14 +1790,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) { - TclEmitInstInt4(INST_LOAD_SCALAR4, 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; } @@ -1836,10 +1810,9 @@ TclCompileDictUpdateCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ - int i, dictIndex, numVars, range, infoIndex; + int i, dictIndex, numVars, range, infoIndex, done; Tcl_Token **keyTokenPtrs, *dictVarTokenPtr, *bodyTokenPtr, *tokenPtr; DictUpdateInfo *duiPtr; - JumpFixup jumpFixup; /* * There must be at least one argument after the command. @@ -1877,9 +1850,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 ; inumWords - 1); - ExceptionRangeEnds(envPtr, range); + OP4( BEGIN_CATCH, range); + CATCH_RANGE(range) { + BODY( bodyTokenPtr, parsePtr->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); + OP4( REVERSE, 2); + 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 @@ -1950,16 +1922,15 @@ TclCompileDictUpdateCmd( */ 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); + 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); - TclFixupForwardJumpToHere(envPtr, &jumpFixup); TclStackFree(interp, keyTokenPtrs); return TCL_OK; @@ -2018,14 +1989,14 @@ TclCompileDictAppendCmd( tokenPtr = TokenAfter(tokenPtr); } if ((int)parsePtr->numWords > 4) { - TclEmitInstInt1(INST_STR_CONCAT1, (int)parsePtr->numWords-3, envPtr); + OP1( STR_CONCAT1, (int)parsePtr->numWords - 3); } /* * Do the concatenation. */ - TclEmitInstInt4(INST_DICT_APPEND, dictVarIndex, envPtr); + OP4( DICT_APPEND, dictVarIndex); return TCL_OK; } @@ -2070,7 +2041,7 @@ TclCompileDictLappendCmd( CompileWord(envPtr, keyTokenPtr, interp, 2); CompileWord(envPtr, valueTokenPtr, interp, 3); - TclEmitInstInt4( INST_DICT_LAPPEND, dictVarIndex, envPtr); + OP4( DICT_LAPPEND, dictVarIndex); return TCL_OK; } @@ -2085,9 +2056,9 @@ TclCompileDictWithCmd( { DefineLineInformation; /* TIP #280 */ int i, range, varNameTmp = -1, pathTmp = -1, keysTmp, gotPath; - int dictVar, bodyIsEmpty = 1; + int dictVar, bodyIsEmpty = 1, done; + int numWords = (int) parsePtr->numWords; Tcl_Token *varTokenPtr, *tokenPtr; - JumpFixup jumpFixup; const char *ptr, *end; /* @@ -2095,7 +2066,7 @@ TclCompileDictWithCmd( */ /* TODO: Consider support for compiling expanded args. */ - if ((int)parsePtr->numWords < 3) { + if (numWords < 3) { return TCL_ERROR; } @@ -2106,7 +2077,7 @@ TclCompileDictWithCmd( varTokenPtr = TokenAfter(parsePtr->tokenPtr); tokenPtr = TokenAfter(varTokenPtr); - for (i=3 ; i<(int)parsePtr->numWords ; i++) { + for (i=3 ; itype != TCL_TOKEN_SIMPLE_WORD) { @@ -2134,7 +2105,7 @@ TclCompileDictWithCmd( * Determine if we're manipulating a dict in a simple local variable. */ - gotPath = ((int)parsePtr->numWords > 3); + gotPath = (numWords > 3); dictVar = LocalScalarFromToken(varTokenPtr, envPtr); /* @@ -2153,25 +2124,25 @@ TclCompileDictWithCmd( */ tokenPtr = TokenAfter(varTokenPtr); - for (i=2 ; i<(int)parsePtr->numWords-1 ; i++) { + for (i=2 ; inumWords-3,envPtr); - TclEmitInstInt4(INST_LOAD_SCALAR4, dictVar, envPtr); - TclEmitInstInt4(INST_OVER, 1, envPtr); - TclEmitOpcode( INST_DICT_EXPAND, envPtr); - TclEmitInstInt4(INST_DICT_RECOMBINE_IMM, dictVar, envPtr); + OP4( LIST, numWords - 3); + OP4( LOAD_SCALAR, dictVar); + OP4( OVER, 1); + OP( DICT_EXPAND); + OP4( DICT_RECOMBINE_IMM, dictVar); } else { /* * Case: Direct dict in LVT with empty body. */ - PushStringLiteral(envPtr, ""); - TclEmitInstInt4(INST_LOAD_SCALAR4, dictVar, envPtr); - PushStringLiteral(envPtr, ""); - TclEmitOpcode( INST_DICT_EXPAND, envPtr); - TclEmitInstInt4(INST_DICT_RECOMBINE_IMM, dictVar, envPtr); + PUSH( ""); + OP4( LOAD_SCALAR, dictVar); + PUSH( ""); + OP( DICT_EXPAND); + OP4( DICT_RECOMBINE_IMM, dictVar); } } else { if (gotPath) { @@ -2180,32 +2151,32 @@ TclCompileDictWithCmd( */ tokenPtr = varTokenPtr; - for (i=1 ; i<(int)parsePtr->numWords-1 ; i++) { + for (i=1 ; inumWords-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); + 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. */ 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); + OP( DUP); + OP( LOAD_STK); + PUSH( ""); + OP( DICT_EXPAND); + PUSH( ""); + OP4( REVERSE, 2); + OP( DICT_RECOMBINE_STK); } } - PushStringLiteral(envPtr, ""); + PUSH( ""); return TCL_OK; } @@ -2231,63 +2202,63 @@ TclCompileDictWithCmd( if (dictVar == -1) { CompileWord(envPtr, varTokenPtr, interp, 1); - TclEmitInstInt4( INST_STORE_SCALAR4, varNameTmp, envPtr); + OP4( STORE_SCALAR, varNameTmp); } tokenPtr = TokenAfter(varTokenPtr); if (gotPath) { - for (i=2 ; i<(int)parsePtr->numWords-1 ; i++) { + for (i=2 ; inumWords-3,envPtr); - TclEmitInstInt4( INST_STORE_SCALAR4, pathTmp, envPtr); - TclEmitOpcode( INST_POP, envPtr); + OP4( LIST, numWords - 3); + OP4( STORE_SCALAR, pathTmp); + OP( POP); } if (dictVar == -1) { - TclEmitOpcode( INST_LOAD_STK, envPtr); + OP( LOAD_STK); } else { - TclEmitInstInt4( INST_LOAD_SCALAR4, dictVar, envPtr); + OP4( LOAD_SCALAR, dictVar); } if (gotPath) { - TclEmitInstInt4( INST_LOAD_SCALAR4, pathTmp, envPtr); + OP4( LOAD_SCALAR, pathTmp); } else { - PushStringLiteral(envPtr, ""); + PUSH( ""); } - TclEmitOpcode( INST_DICT_EXPAND, envPtr); - TclEmitInstInt4( INST_STORE_SCALAR4, 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); + OP4( BEGIN_CATCH, range); - ExceptionRangeStarts(envPtr, range); - BODY(tokenPtr, parsePtr->numWords - 1); - ExceptionRangeEnds(envPtr, range); + CATCH_RANGE(range) { + BODY( tokenPtr, numWords - 1); + } /* * Now fold the results back into the dictionary in the OK case. */ - TclEmitOpcode( INST_END_CATCH, envPtr); + OP( END_CATCH); if (dictVar == -1) { - TclEmitInstInt4( INST_LOAD_SCALAR4, varNameTmp, envPtr); + OP4( LOAD_SCALAR, varNameTmp); } if (gotPath) { - TclEmitInstInt4( INST_LOAD_SCALAR4, pathTmp, envPtr); + OP4( LOAD_SCALAR, pathTmp); } else { - PushStringLiteral(envPtr, ""); + PUSH( ""); } - TclEmitInstInt4( INST_LOAD_SCALAR4, keysTmp, envPtr); + OP4( LOAD_SCALAR, keysTmp); if (dictVar == -1) { - TclEmitOpcode( INST_DICT_RECOMBINE_STK, envPtr); + OP( DICT_RECOMBINE_STK); } else { - TclEmitInstInt4( INST_DICT_RECOMBINE_IMM, dictVar, envPtr); + OP4( DICT_RECOMBINE_IMM, dictVar); } - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); + FWDJUMP( JUMP, done); /* * Now fold the results back into the dictionary in the exception case. @@ -2295,30 +2266,30 @@ TclCompileDictWithCmd( TclAdjustStackDepth(-1, envPtr); ExceptionRangeTarget(envPtr, range, catchOffset); - TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); - TclEmitOpcode( INST_PUSH_RESULT, envPtr); - TclEmitOpcode( INST_END_CATCH, envPtr); + OP( PUSH_RETURN_OPTIONS); + OP( PUSH_RESULT); + OP( END_CATCH); if (dictVar == -1) { - TclEmitInstInt4( INST_LOAD_SCALAR4, varNameTmp, envPtr); + OP4( LOAD_SCALAR, varNameTmp); } - if ((int)parsePtr->numWords > 3) { - TclEmitInstInt4( INST_LOAD_SCALAR4, pathTmp, envPtr); + if (numWords > 3) { + OP4( LOAD_SCALAR, pathTmp); } else { - PushStringLiteral(envPtr, ""); + PUSH( ""); } - TclEmitInstInt4( INST_LOAD_SCALAR4, keysTmp, envPtr); + OP4( LOAD_SCALAR, keysTmp); if (dictVar == -1) { - TclEmitOpcode( INST_DICT_RECOMBINE_STK, envPtr); + OP( DICT_RECOMBINE_STK); } else { - TclEmitInstInt4( INST_DICT_RECOMBINE_IMM, dictVar, envPtr); + OP4( DICT_RECOMBINE_IMM, dictVar); } - TclEmitInvoke(envPtr, INST_RETURN_STK); + INVOKE( RETURN_STK); /* * Prepare for the start of the next command. */ - TclFixupForwardJumpToHere(envPtr, &jumpFixup); + FWDLABEL( done); return TCL_OK; } @@ -2452,18 +2423,18 @@ TclCompileErrorCmd( */ if (parsePtr->numWords == 2) { - PushStringLiteral(envPtr, ""); + PUSH( ""); } else { - PushStringLiteral(envPtr, "-errorinfo"); + PUSH( "-errorinfo"); tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 2); if (parsePtr->numWords == 3) { - TclEmitInstInt4( INST_LIST, 2, envPtr); + OP4( LIST, 2); } else { - PushStringLiteral(envPtr, "-errorcode"); + PUSH( "-errorcode"); tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 3); - TclEmitInstInt4( INST_LIST, 4, envPtr); + OP4( LIST, 4); } } @@ -2471,8 +2442,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; } @@ -2548,9 +2518,7 @@ TclCompileForCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *startTokenPtr, *testTokenPtr, *nextTokenPtr, *bodyTokenPtr; - JumpFixup jumpEvalCondFixup; - int bodyCodeOffset, nextCodeOffset, jumpDist; - int bodyRange, nextRange; + int evalBody, testCondition, evalNext, bodyRange, nextRange; if (parsePtr->numWords != 5) { return TCL_ERROR; @@ -2585,7 +2553,7 @@ TclCompileForCmd( */ BODY(startTokenPtr, 1); - TclEmitOpcode(INST_POP, envPtr); + OP( POP); /* * Jump to the evaluation of the condition. This code uses the "loop @@ -2599,17 +2567,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); + BACKLABEL( evalBody); + CATCH_RANGE(bodyRange) { + BODY( bodyTokenPtr, 4); + } + OP( POP); /* * Compile the "next" subcommand. Note that this exception range will not @@ -2619,32 +2588,32 @@ TclCompileForCmd( 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); + BACKLABEL( evalNext); + CATCH_RANGE(nextRange) { + BODY( nextTokenPtr, 3); + } + OP( POP); /* * Compile the test expression then emit the conditional jump that * terminates the for. */ - TclFixupForwardJumpToHere(envPtr, &jumpEvalCondFixup); + FWDLABEL( testCondition); SetLineInformation(2); TclCompileExprWords(interp, testTokenPtr, 1, envPtr); - jumpDist = CurrentOffset(envPtr) - bodyCodeOffset; - TclEmitInstInt4(INST_JUMP_TRUE4, -jumpDist, envPtr); + 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[bodyRange].codeOffset = evalBody; + envPtr->exceptArrayPtr[bodyRange].continueOffset = evalNext; - envPtr->exceptArrayPtr[nextRange].codeOffset = nextCodeOffset; + envPtr->exceptArrayPtr[nextRange].codeOffset = evalNext; ExceptionRangeTarget(envPtr, bodyRange, breakOffset); ExceptionRangeTarget(envPtr, nextRange, breakOffset); @@ -2655,8 +2624,7 @@ TclCompileForCmd( * The for command's result is an empty string. */ - PushStringLiteral(envPtr, ""); - + PUSH( ""); return TCL_OK; } @@ -2865,7 +2833,7 @@ CompileEachloopCmd( */ if (collect == TCL_EACH_COLLECT) { - TclEmitInstInt4(INST_LIST, 0, envPtr); + OP4( LIST, 0); } /* @@ -2880,7 +2848,7 @@ CompileEachloopCmd( } } - TclEmitInstInt4(INST_FOREACH_START, infoIndex, envPtr); + OP4( FOREACH_START, infoIndex); /* * Inline compile the loop body. @@ -2888,14 +2856,14 @@ CompileEachloopCmd( range = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); - 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); } /* @@ -2904,10 +2872,10 @@ CompileEachloopCmd( */ ExceptionRangeTarget(envPtr, range, continueOffset); - TclEmitOpcode(INST_FOREACH_STEP, envPtr); + OP( FOREACH_STEP); ExceptionRangeTarget(envPtr, range, breakOffset); TclFinalizeLoopExceptionRange(envPtr, range); - TclEmitOpcode(INST_FOREACH_END, envPtr); + OP( FOREACH_END); TclAdjustStackDepth(-(numLists+2), envPtr); /* @@ -2925,7 +2893,7 @@ CompileEachloopCmd( */ if (collect != TCL_EACH_COLLECT) { - PushStringLiteral(envPtr, ""); + PUSH( ""); } done: @@ -3396,7 +3364,7 @@ TclCompileFormatCmd( * Do the concatenation, which produces the result. */ - TclEmitInstInt1(INST_STR_CONCAT1, i, envPtr); + OP1( STR_CONCAT1, i); } return TCL_OK; } @@ -3485,7 +3453,7 @@ TclPushVarName( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Token *varTokenPtr, /* Points to a variable token. */ CompileEnv *envPtr, /* Holds resulting instructions. */ - int flags, /* TCL_NO_LARGE_INDEX | TCL_NO_ELEMENT. */ + int flags, /* TCL_NO_ELEMENT. */ int *localIndexPtr, /* Must not be NULL. */ int *isScalarPtr) /* Must not be NULL. */ { @@ -3493,7 +3461,7 @@ TclPushVarName( const char *last, *name, *elName; Tcl_Size n; Tcl_Token *elemTokenPtr = NULL; - size_t nameLen, elNameLen; + size_t nameLen, elNameLen; int simpleVarName, localIndex; Tcl_Size elemTokenCount = 0, removedParen = 0; int allocedTokens = 0; @@ -3646,13 +3614,6 @@ TclPushVarName( 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); @@ -3668,7 +3629,7 @@ TclPushVarName( TclCompileTokens(interp, elemTokenPtr, elemTokenCount, envPtr); } else { - PushStringLiteral(envPtr, ""); + PUSH( ""); } } } else if (interp) { diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index ccbec85..0a74227 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -15,7 +15,7 @@ */ #include "tclInt.h" -#include "tclCompile.h" +#include "tclCompUtils.h" #include /* @@ -112,7 +112,7 @@ TclCompileGlobalCmd( * Push the namespace */ - PushStringLiteral(envPtr, "::"); + PUSH( "::"); /* * Loop over the variables. @@ -133,15 +133,15 @@ TclCompileGlobalCmd( */ CompileWord(envPtr, varTokenPtr, interp, i); - 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; } @@ -181,8 +181,8 @@ TclCompileIfCmd( * determined. */ Tcl_Token *tokenPtr, *testTokenPtr; int jumpIndex = 0; /* Avoid compiler warning. */ - size_t numBytes, j; - int jumpFalseDist, numWords, wordIdx, code; + size_t numBytes, j; + int numWords, wordIdx, code; const char *word; int realCond = 1; /* Set to 0 for static conditions: * "if 0 {..}" */ @@ -392,7 +392,7 @@ TclCompileIfCmd( */ if (compileScripts) { - PushStringLiteral(envPtr, ""); + PUSH( ""); } } @@ -495,31 +495,29 @@ TclCompileIncrCmd( if (isScalar) { /* Simple scalar variable. */ if (localIndex >= 0) { if (haveImmValue) { - TclEmitInstInt4(INST_INCR_SCALAR4_IMM, localIndex, envPtr); - TclEmitInt1(immValue, envPtr); + OP41( INCR_SCALAR_IMM, localIndex, immValue); } else { - TclEmitInstInt1(INST_INCR_SCALAR4, localIndex, envPtr); + OP4( INCR_SCALAR, localIndex); } } else { if (haveImmValue) { - TclEmitInstInt4(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) { - TclEmitInstInt4(INST_INCR_ARRAY4_IMM, localIndex, envPtr); - TclEmitInt1(immValue, envPtr); + OP41( INCR_ARRAY_IMM, localIndex, immValue); } else { - TclEmitInstInt4(INST_INCR_ARRAY4, 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); } } } @@ -558,7 +556,7 @@ TclCompileInfoCommandsCmd( Tcl_Token *tokenPtr; Tcl_Obj *objPtr; const char *bytes; - JumpFixup isList; + int isList; /* * We require one compile-time known argument for the case we can compile. @@ -594,13 +592,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); - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &isList); - TclEmitInstInt4( INST_LIST, 1, envPtr); - TclFixupForwardJumpToHere(envPtr, &isList); + CompileWord(envPtr, tokenPtr, interp, 1); + OP( RESOLVE_COMMAND); + OP( DUP); + OP( STR_LEN); + FWDJUMP( JUMP_FALSE, isList); + OP4( LIST, 1); + FWDLABEL( isList); return TCL_OK; notCompilable: @@ -628,7 +626,7 @@ TclCompileInfoCoroutineCmd( * Not much to do; we compile to a single instruction... */ - TclEmitOpcode( INST_COROUTINE_NAME, envPtr); + OP( COROUTINE_NAME); return TCL_OK; } @@ -665,15 +663,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); } } @@ -697,7 +695,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 { @@ -709,7 +707,7 @@ TclCompileInfoLevelCmd( */ CompileWord(envPtr, TokenAfter(parsePtr->tokenPtr), interp, 1); - TclEmitOpcode( INST_INFO_LEVEL_ARGS, envPtr); + OP( INFO_LEVEL_ARGS); } return TCL_OK; } @@ -729,7 +727,7 @@ TclCompileInfoObjectClassCmd( return TCL_ERROR; } CompileWord(envPtr, tokenPtr, interp, 1); - TclEmitOpcode( INST_TCLOO_CLASS, envPtr); + OP( TCLOO_CLASS); return TCL_OK; } @@ -764,7 +762,7 @@ TclCompileInfoObjectIsACmd( */ CompileWord(envPtr, tokenPtr, interp, 2); - TclEmitOpcode( INST_TCLOO_IS_OBJECT, envPtr); + OP( TCLOO_IS_OBJECT); return TCL_OK; } @@ -783,7 +781,7 @@ TclCompileInfoObjectNamespaceCmd( return TCL_ERROR; } CompileWord(envPtr, tokenPtr, interp, 1); - TclEmitOpcode( INST_TCLOO_NS, envPtr); + OP( TCLOO_NS); return TCL_OK; } @@ -862,15 +860,15 @@ TclCompileLappendCmd( if (isScalar) { if (localIndex < 0) { - TclEmitOpcode( INST_LAPPEND_STK, envPtr); + OP( LAPPEND_STK); } else { - TclEmitInstInt4( INST_LAPPEND_SCALAR4, localIndex, envPtr); + OP4( LAPPEND_SCALAR, localIndex); } } else { if (localIndex < 0) { - TclEmitOpcode( INST_LAPPEND_ARRAY_STK, envPtr); + OP( LAPPEND_ARRAY_STK); } else { - TclEmitInstInt4( INST_LAPPEND_ARRAY4, localIndex,envPtr); + OP4( LAPPEND_ARRAY, localIndex); } } @@ -885,18 +883,18 @@ TclCompileLappendCmd( CompileWord(envPtr, valueTokenPtr, interp, i); valueTokenPtr = TokenAfter(valueTokenPtr); } - TclEmitInstInt4( INST_LIST, numWords - 2, envPtr); + OP4( LIST, numWords - 2); 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; @@ -970,27 +968,27 @@ TclCompileLassignCmd( if (isScalar) { if (localIndex >= 0) { - TclEmitOpcode( INST_DUP, envPtr); - TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); - TclEmitInstInt4(INST_STORE_SCALAR4, 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); - TclEmitInstInt4(INST_STORE_ARRAY4, 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); } } } @@ -999,8 +997,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; } @@ -1061,7 +1058,7 @@ TclCompileLindexCmd( */ CompileWord(envPtr, valTokenPtr, interp, 1); - TclEmitInstInt4( INST_LIST_INDEX_IMM, idx, envPtr); + OP4( LIST_INDEX_IMM, idx); return TCL_OK; } @@ -1087,9 +1084,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,7 +1128,7 @@ TclCompileListCmd( * [list] without arguments just pushes an empty object. */ - PushStringLiteral(envPtr, ""); + PUSH( ""); return TCL_OK; } @@ -1168,9 +1165,9 @@ TclCompileListCmd( concat = build = 0; for (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; @@ -1178,7 +1175,7 @@ TclCompileListCmd( CompileWord(envPtr, valueTokenPtr, interp, i); if (valueTokenPtr->type == TCL_TOKEN_EXPAND_WORD) { if (concat) { - TclEmitOpcode( INST_LIST_CONCAT, envPtr); + OP( LIST_CONCAT); } else { concat = 1; } @@ -1188,9 +1185,9 @@ TclCompileListCmd( valueTokenPtr = TokenAfter(valueTokenPtr); } if (build > 0) { - TclEmitInstInt4( INST_LIST, build, envPtr); + OP4( LIST, build); if (concat) { - TclEmitOpcode( INST_LIST_CONCAT, envPtr); + OP( LIST_CONCAT); } } @@ -1202,8 +1199,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; } @@ -1243,7 +1239,7 @@ TclCompileLlengthCmd( varTokenPtr = TokenAfter(parsePtr->tokenPtr); CompileWord(envPtr, varTokenPtr, interp, 1); - TclEmitOpcode( INST_LIST_LENGTH, envPtr); + OP( LIST_LENGTH); return TCL_OK; } @@ -1302,8 +1298,7 @@ TclCompileLrangeCmd( */ CompileWord(envPtr, listTokenPtr, interp, 1); - TclEmitInstInt4( INST_LIST_RANGE_IMM, idx1, envPtr); - TclEmitInt4( idx2, envPtr); + OP44( LIST_RANGE_IMM, idx1, idx2); return TCL_OK; } @@ -1346,15 +1341,15 @@ TclCompileLinsertCmd( CompileWord(envPtr, tokenPtr, interp, 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 * indicating this is a pure insert */ - TclEmitInt1(TCL_LREPLACE4_SINGLE_INDEX, envPtr); + OP41( LREPLACE, parsePtr->numWords - 1, + TCL_LREPLACE4_SINGLE_INDEX); return TCL_OK; } @@ -1400,14 +1395,13 @@ TclCompileLreplaceCmd( CompileWord(envPtr, tokenPtr, interp, 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 */ - TclEmitInt1(TCL_LREPLACE4_END_IS_LAST, envPtr); - + OP41( LREPLACE, parsePtr->numWords - 1, + TCL_LREPLACE4_END_IS_LAST); return TCL_OK; } @@ -1512,7 +1506,7 @@ TclCompileLsetCmd( } else { tempDepth = parsePtr->numWords - 1; } - TclEmitInstInt4( INST_OVER, tempDepth, envPtr); + OP4( OVER, tempDepth); } /* @@ -1525,7 +1519,7 @@ TclCompileLsetCmd( } else { tempDepth = parsePtr->numWords - 2; } - TclEmitInstInt4( INST_OVER, tempDepth, envPtr); + OP4( OVER, tempDepth); } /* @@ -1534,15 +1528,15 @@ TclCompileLsetCmd( if (isScalar) { if (localIndex < 0) { - TclEmitOpcode( INST_LOAD_STK, envPtr); + OP( LOAD_STK); } else { - TclEmitInstInt4( INST_LOAD_SCALAR4, localIndex, envPtr); + OP4( LOAD_SCALAR, localIndex); } } else { if (localIndex < 0) { - TclEmitOpcode( INST_LOAD_ARRAY_STK, envPtr); + OP( LOAD_ARRAY_STK); } else { - TclEmitInstInt4( INST_LOAD_ARRAY4, localIndex, envPtr); + OP4( LOAD_ARRAY, localIndex); } } @@ -1551,9 +1545,9 @@ TclCompileLsetCmd( */ if (parsePtr->numWords == 4) { - TclEmitOpcode( INST_LSET_LIST, envPtr); + OP( LSET_LIST); } else { - TclEmitInstInt4( INST_LSET_FLAT, parsePtr->numWords-1, envPtr); + OP4( LSET_FLAT, parsePtr->numWords - 1); } /* @@ -1562,15 +1556,15 @@ TclCompileLsetCmd( if (isScalar) { if (localIndex < 0) { - TclEmitOpcode( INST_STORE_STK, envPtr); + OP( STORE_STK); } else { - TclEmitInstInt4( INST_STORE_SCALAR4, localIndex, envPtr); + OP4( STORE_SCALAR, localIndex); } } else { if (localIndex < 0) { - TclEmitOpcode( INST_STORE_ARRAY_STK, envPtr); + OP( STORE_ARRAY_STK); } else { - TclEmitInstInt4( INST_STORE_ARRAY4, localIndex, envPtr); + OP4( STORE_ARRAY, localIndex); } } @@ -1617,7 +1611,7 @@ TclCompileNamespaceCurrentCmd( * Not much to do; we compile to a single instruction... */ - TclEmitOpcode( INST_NS_CURRENT, envPtr); + OP( NS_CURRENT); return TCL_OK; } @@ -1662,11 +1656,11 @@ TclCompileNamespaceCodeCmd( * the value needs to be determined at runtime for safety. */ - PushStringLiteral(envPtr, "::namespace"); - PushStringLiteral(envPtr, "inscope"); - TclEmitOpcode( INST_NS_CURRENT, envPtr); + PUSH( "::namespace"); + PUSH( "inscope"); + OP( NS_CURRENT); CompileWord(envPtr, tokenPtr, interp, 1); - TclEmitInstInt4( INST_LIST, 4, envPtr); + OP4( LIST, 4); return TCL_OK; } @@ -1687,7 +1681,7 @@ TclCompileNamespaceOriginCmd( tokenPtr = TokenAfter(parsePtr->tokenPtr); CompileWord(envPtr, tokenPtr, interp, 1); - TclEmitOpcode( INST_ORIGIN_COMMAND, envPtr); + OP( ORIGIN_COMMAND); return TCL_OK; } @@ -1708,21 +1702,20 @@ TclCompileNamespaceQualifiersCmd( } 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); - TclEmitInstInt4( INST_JUMP_TRUE4, off, envPtr); - TclEmitOpcode( INST_STR_RANGE, envPtr); + 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; } @@ -1736,7 +1729,7 @@ TclCompileNamespaceTailCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); - JumpFixup jumpFixup; + int offset; if (parsePtr->numWords != 2) { return TCL_ERROR; @@ -1747,18 +1740,18 @@ TclCompileNamespaceTailCmd( */ 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); - PushStringLiteral(envPtr, "end"); - TclEmitOpcode( INST_STR_RANGE, envPtr); + PUSH( "::"); + OP4( OVER, 1); + OP( STR_FIND_LAST); + OP( DUP); + PUSH( "0"); + OP( GE); + FWDJUMP( JUMP_FALSE, offset); + PUSH( "2"); + OP( ADD); + FWDLABEL( offset); + PUSH( "end"); + OP( STR_RANGE); return TCL_OK; } @@ -1810,15 +1803,15 @@ TclCompileNamespaceUpvarCmd( 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; } @@ -1863,7 +1856,7 @@ TclCompileNamespaceWhichCmd( */ CompileWord(envPtr, tokenPtr, interp, idx); - TclEmitOpcode( INST_RESOLVE_COMMAND, envPtr); + OP( RESOLVE_COMMAND); return TCL_OK; } @@ -1983,7 +1976,7 @@ TclCompileRegexpCmd( * The semantics of regexp are always match on re == "". */ - PushStringLiteral(envPtr, "1"); + PUSH( "1"); return TCL_OK; } @@ -2013,9 +2006,9 @@ TclCompileRegexpCmd( 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 { /* @@ -2026,7 +2019,7 @@ TclCompileRegexpCmd( int cflags = TCL_REG_ADVANCED | (nocase ? TCL_REG_NOCASE : 0); - TclEmitInstInt1( INST_REGEXP, cflags, envPtr); + OP1( REGEXP, cflags); } return TCL_OK; @@ -2194,7 +2187,7 @@ TclCompileRegsubCmd( bytes = TclGetStringFromObj(replacementObj, &len); PushLiteral(envPtr, bytes, len); CompileWord(envPtr, stringTokenPtr, interp, (int)parsePtr->numWords - 2); - TclEmitOpcode( INST_STR_MAP, envPtr); + OP( STR_MAP); done: Tcl_DStringFree(&pattern); @@ -2263,7 +2256,7 @@ TclCompileReturnCmd( CompileWord(envPtr, optsTokenPtr, interp, 2); CompileWord(envPtr, msgTokenPtr, interp, 3); - TclEmitInvoke(envPtr, INST_RETURN_STK); + INVOKE( RETURN_STK); return TCL_OK; } @@ -2328,7 +2321,7 @@ TclCompileReturnCmd( * No explict result argument, so default result is empty string. */ - PushStringLiteral(envPtr, ""); + PUSH( ""); } /* @@ -2362,7 +2355,7 @@ TclCompileReturnCmd( */ Tcl_DecrRefCount(returnOpts); - TclEmitOpcode(INST_DONE, envPtr); + OP( DONE); TclAdjustStackDepth(1, envPtr); return TCL_OK; } @@ -2393,7 +2386,7 @@ TclCompileReturnCmd( CompileWord(envPtr, wordTokenPtr, interp, objc); wordTokenPtr = TokenAfter(wordTokenPtr); } - TclEmitInstInt4(INST_LIST, numOptionWords, envPtr); + OP4( LIST, numOptionWords); /* * Push the result. @@ -2402,14 +2395,14 @@ TclCompileReturnCmd( if (explicitResult) { CompileWord(envPtr, wordTokenPtr, interp, numWords - 1); } else { - PushStringLiteral(envPtr, ""); + PUSH( ""); } /* * Issue the RETURN itself. */ - TclEmitInvoke(envPtr, INST_RETURN_STK); + INVOKE( RETURN_STK); return TCL_OK; } @@ -2439,8 +2432,7 @@ CompileReturnInternal( } TclEmitPush(TclAddLiteralObj(envPtr, returnOpts, NULL), envPtr); - TclEmitInstInt4(op, code, envPtr); - TclEmitInt4(level, envPtr); + TclEmitInstInt44(op, code, level, envPtr); } void @@ -2530,7 +2522,7 @@ TclCompileUpvarCmd( if (!(numWords%2)) { return TCL_ERROR; } - PushStringLiteral(envPtr, "1"); + PUSH( "1"); otherTokenPtr = tokenPtr; i = 1; } @@ -2553,15 +2545,15 @@ TclCompileUpvarCmd( 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; } @@ -2627,7 +2619,7 @@ TclCompileVariableCmd( * IndexTailVarIfKnown() screen. Full CompileWord() * likely does not apply here. Push known value instead. */ CompileWord(envPtr, varTokenPtr, interp, i); - TclEmitInstInt4( INST_VARIABLE, localIndex, envPtr); + OP4( VARIABLE, localIndex); if (i + 1 < numWords) { /* @@ -2635,8 +2627,8 @@ TclCompileVariableCmd( */ CompileWord(envPtr, valueTokenPtr, interp, i + 1); - TclEmitInstInt4( INST_STORE_SCALAR4, localIndex, envPtr); - TclEmitOpcode( INST_POP, envPtr); + OP4( STORE_SCALAR, localIndex); + OP( POP); } } @@ -2644,7 +2636,7 @@ TclCompileVariableCmd( * Set the result to empty */ - PushStringLiteral(envPtr, ""); + PUSH( ""); return TCL_OK; } @@ -2769,15 +2761,11 @@ TclCompileObjectNextCmd( Tcl_Token *tokenPtr = parsePtr->tokenPtr; int i; - if ((int)parsePtr->numWords > 255) { - return TCL_ERROR; - } - for (i=0 ; i<(int)parsePtr->numWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } - TclEmitInstInt1( INST_TCLOO_NEXT, i, envPtr); + TclEmitInvoke(envPtr, INST_TCLOO_NEXT, i); return TCL_OK; } @@ -2793,7 +2781,7 @@ TclCompileObjectNextToCmd( Tcl_Token *tokenPtr = parsePtr->tokenPtr; int i; - if ((int)parsePtr->numWords < 2 || (int)parsePtr->numWords > 255) { + if ((int)parsePtr->numWords < 2) { return TCL_ERROR; } @@ -2801,7 +2789,7 @@ TclCompileObjectNextToCmd( CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } - TclEmitInstInt1( INST_TCLOO_NEXT_CLASS, i, envPtr); + TclEmitInvoke(envPtr, INST_TCLOO_NEXT_CLASS, i); return TCL_OK; } @@ -2848,7 +2836,7 @@ TclCompileObjectSelfCmd( * This delegates the entire problem to a single opcode. */ - TclEmitOpcode( INST_TCLOO_SELF, envPtr); + OP( TCLOO_SELF); return TCL_OK; compileSelfNamespace: @@ -2861,9 +2849,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 7d537cb..74385fd 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -16,7 +16,7 @@ */ #include "tclInt.h" -#include "tclCompile.h" +#include "tclCompUtils.h" #include "tclStringTrim.h" /* @@ -73,34 +73,6 @@ const AuxDataType tclJumptableInfoType = { PrintJumptableInfo, /* printProc */ 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 LABEL(var) \ - (var) = CurrentOffset(envPtr) -#define BACKJUMP4(name, var) \ - TclEmitInstInt4(INST_##name##4,(var)-CurrentOffset(envPtr),envPtr) -#define JUMP4(name,var) \ - LABEL(var);TclEmitInstInt4(INST_##name##4,0,envPtr) -#define FIXJUMP4(var) \ - TclStoreInt4AtPtr(CurrentOffset(envPtr)-(var),envPtr->codeStart+(var)+1) -#define LOAD(idx) \ - OP4(LOAD_SCALAR4,(idx)) -#define STORE(idx) \ - OP4(STORE_SCALAR4,(idx)) -#define INVOKE(name) \ - TclEmitInvoke(envPtr,INST_##name) /* *---------------------------------------------------------------------- @@ -163,25 +135,25 @@ TclCompileSetCmd( * Emit instructions to set/get the variable. */ - if (isScalar) { - if (localIndex < 0) { - TclEmitOpcode((isAssignment? - INST_STORE_STK : INST_LOAD_STK), envPtr); - } else { - TclEmitInstInt4((isAssignment? - INST_STORE_SCALAR4 : INST_LOAD_SCALAR4), - localIndex, envPtr); - } + if (isScalar) { + if (localIndex < 0) { + TclEmitOpcode((isAssignment? + INST_STORE_STK : INST_LOAD_STK), envPtr); } else { - if (localIndex < 0) { - TclEmitOpcode((isAssignment? - INST_STORE_ARRAY_STK : INST_LOAD_ARRAY_STK), envPtr); - } else { - TclEmitInstInt4((isAssignment? - INST_STORE_ARRAY4 : INST_LOAD_ARRAY4), - localIndex, envPtr); - } + TclEmitInstInt4((isAssignment? + INST_STORE_SCALAR : INST_LOAD_SCALAR), + localIndex, envPtr); } + } else { + if (localIndex < 0) { + TclEmitOpcode((isAssignment? + INST_STORE_ARRAY_STK : INST_LOAD_ARRAY_STK), envPtr); + } else { + TclEmitInstInt4((isAssignment? + INST_STORE_ARRAY : INST_LOAD_ARRAY), + localIndex, envPtr); + } + } return TCL_OK; } @@ -220,8 +192,8 @@ TclCompileStringCatCmd( /* Trivial case, no arg */ - if (numWords<2) { - PushStringLiteral(envPtr, ""); + if (numWords < 2) { + PUSH( ""); return TCL_OK; } @@ -254,7 +226,7 @@ TclCompileStringCatCmd( CompileWord(envPtr, wordTokenPtr, interp, 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 */ } } @@ -270,7 +242,7 @@ TclCompileStringCatCmd( numArgs ++; } if (numArgs > 1) { - TclEmitInstInt1(INST_STR_CONCAT1, numArgs, envPtr); + OP1( STR_CONCAT1, numArgs); } return TCL_OK; @@ -303,7 +275,7 @@ TclCompileStringCmpCmd( CompileWord(envPtr, tokenPtr, interp, 1); tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 2); - TclEmitOpcode(INST_STR_CMP, envPtr); + OP( STR_CMP); return TCL_OK; } @@ -334,7 +306,7 @@ TclCompileStringEqualCmd( CompileWord(envPtr, tokenPtr, interp, 1); tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 2); - TclEmitOpcode(INST_STR_EQ, envPtr); + OP( STR_EQ); return TCL_OK; } @@ -365,7 +337,7 @@ TclCompileStringFirstCmd( CompileWord(envPtr, tokenPtr, interp, 1); tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 2); - OP(STR_FIND); + OP( STR_FIND); return TCL_OK; } @@ -396,7 +368,7 @@ TclCompileStringLastCmd( CompileWord(envPtr, tokenPtr, interp, 1); tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 2); - OP(STR_FIND_LAST); + OP( STR_FIND_LAST); return TCL_OK; } @@ -423,7 +395,7 @@ TclCompileStringIndexCmd( CompileWord(envPtr, tokenPtr, interp, 1); tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 2); - TclEmitOpcode(INST_STR_INDEX, envPtr); + OP( STR_INDEX); return TCL_OK; } @@ -462,22 +434,22 @@ TclCompileStringInsertCmd( if (idx == (int)TCL_INDEX_START) { /* Prepend the insertion string */ - OP4( REVERSE, 2); - OP1( STR_CONCAT1, 2); + OP4( REVERSE, 2); + 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; @@ -607,69 +579,69 @@ 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); - JUMP4( JUMP_TRUE, over); - OP( POP); - PUSH( "0"); - JUMP4( JUMP, over2); - FIXJUMP4(over); - PUSH( ""); - OP( STR_NEQ); - FIXJUMP4(over2); + OP( DUP); + OP1( STR_CLASS, strClassType); + FWDJUMP( JUMP_TRUE, over); + OP( POP); + PUSH( "0"); + FWDJUMP( JUMP, over2); + FWDLABEL( over); + PUSH( ""); + OP( STR_NEQ); + 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; case STR_IS_BOOL: if (allowEmpty) { - JUMP4( JUMP_TRUE, over); - PUSH( ""); - OP( STR_EQ); - JUMP4( JUMP, over2); - FIXJUMP4(over); - OP( POP); - PUSH( "1"); - FIXJUMP4(over2); + FWDJUMP( JUMP_TRUE, over); + PUSH( ""); + OP( STR_EQ); + FWDJUMP( JUMP, over2); + FWDLABEL(over); + OP( POP); + PUSH( "1"); + FWDLABEL(over2); } else { - OP4( REVERSE, 2); - OP( POP); + OP4( REVERSE, 2); + OP( POP); } return TCL_OK; case STR_IS_TRUE: - JUMP4( JUMP_TRUE, over); + FWDJUMP( JUMP_TRUE, over); if (allowEmpty) { - PUSH( ""); - OP( STR_EQ); + PUSH( ""); + OP( STR_EQ); } else { - OP( POP); - PUSH( "0"); + OP( POP); + PUSH( "0"); } - FIXJUMP4( over); - OP( LNOT); - OP( LNOT); + FWDLABEL( over); + OP( LNOT); + OP( LNOT); return TCL_OK; case STR_IS_FALSE: - JUMP4( JUMP_TRUE, over); + FWDJUMP( JUMP_TRUE, over); if (allowEmpty) { - PUSH( ""); - OP( STR_NEQ); + PUSH( ""); + OP( STR_NEQ); } else { - OP( POP); - PUSH( "1"); + OP( POP); + PUSH( "1"); } - FIXJUMP4( over); - OP( LNOT); + FWDLABEL( over); + OP( LNOT); return TCL_OK; default: break; @@ -680,27 +652,27 @@ TclCompileStringIsCmd( int satisfied, isEmpty; if (allowEmpty) { - OP( DUP); - PUSH( ""); - OP( STR_EQ); - JUMP4( JUMP_TRUE, isEmpty); - OP( NUM_TYPE); - JUMP4( JUMP_TRUE, satisfied); - PUSH( "0"); - JUMP4( JUMP, end); - FIXJUMP4( isEmpty); - OP( POP); - FIXJUMP4( satisfied); + OP( DUP); + PUSH( ""); + OP( STR_EQ); + 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); - JUMP4( JUMP_TRUE, satisfied); - PUSH( "0"); - JUMP4( JUMP, end); + OP( NUM_TYPE); + FWDJUMP( JUMP_TRUE, satisfied); + PUSH( "0"); + FWDJUMP( JUMP, end); TclAdjustStackDepth(-1, envPtr); - FIXJUMP4( satisfied); + FWDLABEL( satisfied); } - PUSH( "1"); - FIXJUMP4( end); + PUSH( "1"); + FWDLABEL( end); return TCL_OK; } @@ -710,65 +682,65 @@ TclCompileStringIsCmd( if (allowEmpty) { int testNumType; - OP( DUP); - OP( NUM_TYPE); - OP( DUP); - JUMP4( JUMP_TRUE, testNumType); - OP( POP); - PUSH( ""); - OP( STR_EQ); - JUMP4( JUMP, end); + OP( DUP); + OP( NUM_TYPE); + OP( DUP); + FWDJUMP( JUMP_TRUE, testNumType); + OP( POP); + PUSH( ""); + OP( STR_EQ); + FWDJUMP( JUMP, end); TclAdjustStackDepth(1, envPtr); - FIXJUMP4( testNumType); - OP4( REVERSE, 2); - OP( POP); + FWDLABEL( testNumType); + OP4( REVERSE, 2); + OP( POP); } else { - OP( NUM_TYPE); - OP( DUP); - JUMP4( 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; } - FIXJUMP4( 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); + OP4( BEGIN_CATCH, range); + OP( DUP); + CATCH_RANGE(range) { + OP( DICT_VERIFY); + } ExceptionRangeTarget(envPtr, range, catchOffset); - OP( POP); - OP( PUSH_RETURN_CODE); - OP( END_CATCH); - OP( LNOT); + 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); + OP4( BEGIN_CATCH, range); + OP( DUP); + CATCH_RANGE(range) { + OP( LIST_LENGTH); + } + OP( POP); ExceptionRangeTarget(envPtr, range, catchOffset); - OP( POP); - OP( PUSH_RETURN_CODE); - OP( END_CATCH); - OP( LNOT); + OP( POP); + OP( PUSH_RETURN_CODE); + OP( END_CATCH); + OP( LNOT); return TCL_OK; } @@ -850,9 +822,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,7 +862,7 @@ TclCompileStringLenCmd( } else { SetLineInformation(1); CompileTokens(envPtr, tokenPtr, interp); - TclEmitOpcode(INST_STR_LEN, envPtr); + OP( STR_LEN); } TclDecrRefCount(objPtr); return TCL_OK; @@ -953,7 +925,7 @@ TclCompileStringMapCmd( bytes = TclGetStringFromObj(objv[1], &slen); PushLiteral(envPtr, bytes, slen); CompileWord(envPtr, stringTokenPtr, interp, 2); - OP(STR_MAP); + OP( STR_MAP); } Tcl_DecrRefCount(mapObj); return TCL_OK; @@ -996,8 +968,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; } @@ -1011,8 +983,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; } @@ -1020,7 +992,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; /* @@ -1030,7 +1002,7 @@ TclCompileStringRangeCmd( nonConstantIndices: CompileWord(envPtr, fromTokenPtr, interp, 2); CompileWord(envPtr, toTokenPtr, interp, 3); - OP( STR_RANGE); + OP( STR_RANGE); return TCL_OK; } @@ -1114,7 +1086,7 @@ TclCompileStringReplaceCmd( if (parsePtr->numWords == 5) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 4); - OP( POP); /* Pop newString */ + OP( POP); /* Pop newString */ } /* Original string argument now on TOS as result */ return TCL_OK; @@ -1164,21 +1136,21 @@ TclCompileStringReplaceCmd( /* empty prefix */ tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 4); - OP4( REVERSE, 2); + OP4( REVERSE, 2); if (last == INT_MAX) { - OP( POP); /* Pop original */ + OP( POP); /* Pop original */ } else { - OP44( STR_RANGE_IMM, last + 1, (int)TCL_INDEX_END); - OP1( STR_CONCAT1, 2); + OP44( STR_RANGE_IMM, last + 1, (int)TCL_INDEX_END); + 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); + OP44( STR_RANGE_IMM, 0, first-1); tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 4); - OP1( STR_CONCAT1, 2); + OP1( STR_CONCAT1, 2); return TCL_OK; } @@ -1196,23 +1168,23 @@ 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, (int)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); + OP4( REVERSE, 2); + OP44( STR_RANGE_IMM, last + 1, (int)TCL_INDEX_END); + OP1( STR_CONCAT1, 2); return TCL_OK; } } @@ -1226,9 +1198,9 @@ TclCompileStringReplaceCmd( tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 4); } else { - PUSH( ""); + PUSH( ""); } - OP( STR_REPLACE); + OP( STR_REPLACE); return TCL_OK; } @@ -1255,7 +1227,7 @@ TclCompileStringTrimLCmd( } else { PushLiteral(envPtr, tclDefaultTrimSet, strlen(tclDefaultTrimSet)); } - OP( STR_TRIM_LEFT); + OP( STR_TRIM_LEFT); return TCL_OK; } @@ -1282,7 +1254,7 @@ TclCompileStringTrimRCmd( } else { PushLiteral(envPtr, tclDefaultTrimSet, strlen(tclDefaultTrimSet)); } - OP( STR_TRIM_RIGHT); + OP( STR_TRIM_RIGHT); return TCL_OK; } @@ -1309,7 +1281,7 @@ TclCompileStringTrimCmd( } else { PushLiteral(envPtr, tclDefaultTrimSet, strlen(tclDefaultTrimSet)); } - OP( STR_TRIM); + OP( STR_TRIM); return TCL_OK; } @@ -1331,7 +1303,7 @@ TclCompileStringToUpperCmd( tokenPtr = TokenAfter(parsePtr->tokenPtr); CompileWord(envPtr, tokenPtr, interp, 1); - OP( STR_UPPER); + OP( STR_UPPER); return TCL_OK; } @@ -1353,7 +1325,7 @@ TclCompileStringToLowerCmd( tokenPtr = TokenAfter(parsePtr->tokenPtr); CompileWord(envPtr, tokenPtr, interp, 1); - OP( STR_LOWER); + OP( STR_LOWER); return TCL_OK; } @@ -1375,7 +1347,7 @@ TclCompileStringToTitleCmd( tokenPtr = TokenAfter(parsePtr->tokenPtr); CompileWord(envPtr, tokenPtr, interp, 1); - OP( STR_TITLE); + OP( STR_TITLE); return TCL_OK; } @@ -1537,7 +1509,7 @@ TclSubstCompile( for (endTokenPtr = tokenPtr + parse.numTokens; tokenPtr < endTokenPtr; tokenPtr = TokenAfter(tokenPtr)) { Tcl_Size length; - int literal, catchRange, breakJump, end; + int literal, catchRange, end; int haveOk, haveReturn, haveBreak, haveContinue, haveOther; char buf[4] = ""; @@ -1600,40 +1572,38 @@ TclSubstCompile( if (breakOffset == 0) { int start; /* Jump to the start (jump over the jump to end) */ - JUMP4( JUMP, start); + FWDJUMP( JUMP, start); /* Jump to the end (all BREAKs land here) */ - JUMP4( JUMP, breakOffset); + FWDJUMP( JUMP, breakOffset); /* Start */ - FIXJUMP4( start); + 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); + 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); - JUMP4( JUMP, haveOk); + FWDJUMP( JUMP, haveOk); TclAdjustStackDepth(-1, envPtr); /* Exceptional return codes processed here */ @@ -1642,7 +1612,7 @@ TclSubstCompile( OP( PUSH_RESULT); OP( PUSH_RETURN_CODE); OP( END_CATCH); - OP( RETURN_CODE_BRANCH4); + OP( RETURN_CODE_BRANCH); /* ERROR -> reraise it; NB: can't require BREAK/CONTINUE handling */ OP( RETURN_STK); @@ -1652,36 +1622,36 @@ TclSubstCompile( OP( NOP); /* RETURN */ - JUMP4( JUMP, haveReturn); + FWDJUMP( JUMP, haveReturn); /* BREAK */ - JUMP4( JUMP, haveBreak); + FWDJUMP( JUMP, haveBreak); /* CONTINUE */ - JUMP4( JUMP, haveContinue); + FWDJUMP( JUMP, haveContinue); /* OTHER */ - JUMP4( JUMP, haveOther); + FWDJUMP( JUMP, haveOther); TclAdjustStackDepth(1, envPtr); /* BREAK destination */ - FIXJUMP4( haveBreak); + FWDLABEL( haveBreak); OP( POP); OP( POP); - BACKJUMP4( JUMP, breakOffset); + BACKJUMP( JUMP, breakOffset); TclAdjustStackDepth(2, envPtr); /* CONTINUE destination */ - FIXJUMP4( haveContinue); + FWDLABEL( haveContinue); OP( POP); OP( POP); - JUMP4( JUMP, end); + FWDJUMP( JUMP, end); TclAdjustStackDepth(2, envPtr); /* RETURN + other destination */ - FIXJUMP4( haveReturn); - FIXJUMP4( haveOther); + FWDLABEL( haveReturn); + FWDLABEL( haveOther); /* * Pull the result to top of stack, discard options dict. @@ -1691,14 +1661,14 @@ TclSubstCompile( OP( POP); /* OK destination */ - FIXJUMP4( haveOk); + FWDLABEL( haveOk); if (count > 1) { OP1( STR_CONCAT1, count); count = 1; } /* CONTINUE jump to here */ - FIXJUMP4( end); + FWDLABEL( end); bline = envPtr->line; } @@ -1720,7 +1690,7 @@ TclSubstCompile( /* Final target of the multi-jump from all BREAKs */ if (breakOffset > 0) { - FIXJUMP4( breakOffset); + FWDLABEL( breakOffset); } } @@ -2122,14 +2092,14 @@ IssueSwitchChainedTests( switch (mode) { case Switch_Exact: - OP( DUP); + OP( DUP); TclCompileTokens(interp, bodyToken[i], 1, envPtr); - OP( STR_EQ); + OP( STR_EQ); break; case Switch_Glob: TclCompileTokens(interp, bodyToken[i], 1, envPtr); - OP4( OVER, 1); - OP1( STR_MATCH, noCase); + OP4( OVER, 1); + OP1( STR_MATCH, noCase); break; case Switch_Regexp: simple = exact = 0; @@ -2168,7 +2138,7 @@ IssueSwitchChainedTests( TclCompileTokens(interp, bodyToken[i], 1, envPtr); } - OP4( OVER, 1); + OP4( OVER, 1); if (!simple) { /* * Pass correct RE compile flags. We use only Int1 @@ -2180,11 +2150,11 @@ IssueSwitchChainedTests( 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: @@ -2249,7 +2219,7 @@ IssueSwitchChainedTests( * pattern. */ - OP( POP); + OP( POP); envPtr->line = bodyLines[i+1]; /* TIP #280 */ envPtr->clNext = bodyContLines[i+1]; /* TIP #280 */ TclCompileCmdWord(interp, bodyToken[i+1], 1, envPtr); @@ -2270,8 +2240,8 @@ IssueSwitchChainedTests( */ if (!foundDefault) { - OP( POP); - PUSH(""); + OP( POP); + PUSH( ""); } /* @@ -2281,7 +2251,7 @@ IssueSwitchChainedTests( for (i=0 ; icodeNext-envPtr->codeStart; + fixupTargetArray[i] = CurrentOffset(envPtr); } } @@ -2358,9 +2328,9 @@ IssueSwitchJumpTable( * because that makes the code much easier to debug! */ - LABEL(jumpLocation); - OP4( JUMP_TABLE, infoIndex); - JUMP4( JUMP, jumpToDefault); + BACKLABEL(jumpLocation); + OP4( JUMP_TABLE, infoIndex); + FWDJUMP( JUMP, jumpToDefault); for (i=0 ; itokenPtr; int i; - if (parsePtr->numWords < 2 || parsePtr->numWords >= 256 - || envPtr->procPtr == NULL) { + if (parsePtr->numWords < 2 || envPtr->procPtr == NULL) { return TCL_ERROR; } @@ -2628,7 +2597,7 @@ TclCompileTailcallCmd( tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, i); } - TclEmitInstInt1( INST_TAILCALL, (int)parsePtr->numWords, envPtr); + OP4( TAILCALL, (int)parsePtr->numWords); return TCL_OK; } @@ -2721,11 +2690,11 @@ TclCompileThrowCmd( OP4( REVERSE, 3); OP( DUP); OP( LIST_LENGTH); - JUMP4( JUMP_FALSE, popForError); + FWDJUMP( JUMP_FALSE, popForError); OP4( LIST, 2); OP44( RETURN_IMM, TCL_ERROR, 0); TclAdjustStackDepth(2, envPtr); - FIXJUMP4( popForError); + FWDLABEL( popForError); OP( POP); OP( POP); OP( POP); @@ -3036,33 +3005,32 @@ IssueTryClausesInstructions( */ range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); - OP4( BEGIN_CATCH4, range); - ExceptionRangeStarts(envPtr, range); - BODY( bodyToken, 1); - ExceptionRangeEnds(envPtr, range); + OP4( BEGIN_CATCH, range); + CATCH_RANGE(range) { + BODY( bodyToken, 1); + } if (!trapZero) { - OP( END_CATCH); - JUMP4( JUMP, afterBody); + OP( END_CATCH); + FWDJUMP( JUMP, afterBody); TclAdjustStackDepth(-1, envPtr); } else { - /* - * Fake a return code to go with our result. - */ - OP4( REVERSE, 2); - JUMP4( JUMP, pushReturnOptions); + PUSH( "0"); + OP4( REVERSE, 2); + FWDJUMP( JUMP, pushReturnOptions); TclAdjustStackDepth(-2, envPtr); } ExceptionRangeTarget(envPtr, range, catchOffset); - OP( PUSH_RETURN_CODE); - OP( PUSH_RESULT); + OP( PUSH_RETURN_CODE); + OP( PUSH_RESULT); if (pushReturnOptions) { - FIXJUMP4( pushReturnOptions); + FWDLABEL( pushReturnOptions); } - OP( END_CATCH); - STORE( optionsVar); - OP( POP); - STORE( resultVar); - OP( POP); + 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. @@ -3078,10 +3046,10 @@ IssueTryClausesInstructions( for (i=0 ; i= 0) { - LOAD( resultVar); - STORE( resultVars[i]); - OP( POP); + OP4( LOAD_SCALAR, resultVar); + OP4( STORE_SCALAR, resultVars[i]); + OP( POP); if (optionVars[i] >= 0) { - LOAD( optionsVar); - STORE( optionVars[i]); - OP( POP); + OP4( LOAD_SCALAR, optionsVar); + OP4( STORE_SCALAR, optionVars[i]); + OP( POP); } } if (!handlerTokens[i]) { forwardsNeedFixing = 1; - JUMP4( JUMP, forwardsToFix[i]); + FWDJUMP( JUMP, forwardsToFix[i]); TclAdjustStackDepth(1, envPtr); } else { int dontChangeOptions; @@ -3134,44 +3102,44 @@ IssueTryClausesInstructions( if (forwardsToFix[j] == -1) { continue; } - FIXJUMP4( forwardsToFix[j]); + FWDLABEL(forwardsToFix[j]); forwardsToFix[j] = -1; } } 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]); + OP4( BEGIN_CATCH, range); + CATCH_RANGE(range) { + BODY( handlerTokens[i], 5+i*4); + } + OP( END_CATCH); + FWDJUMP( 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); - JUMP4( JUMP_FALSE, dontChangeOptions); - LOAD( optionsVar); - OP4( REVERSE, 2); - STORE( optionsVar); - OP( POP); - PUSH( "-during"); - OP4( REVERSE, 2); - OP44( DICT_SET, 1, optionsVar); + OP( PUSH_RESULT); + OP( PUSH_RETURN_OPTIONS); + OP( PUSH_RETURN_CODE); + OP( END_CATCH); + PUSH( "1"); + OP( EQ); + FWDJUMP( JUMP_FALSE, dontChangeOptions); + OP4( LOAD_SCALAR, optionsVar); + OP4( REVERSE, 2); + OP4( STORE_SCALAR, optionsVar); + OP( POP); + PUSH( "-during"); + OP4( REVERSE, 2); + OP44( DICT_SET, 1, optionsVar); TclAdjustStackDepth(-1, envPtr); - FIXJUMP4( dontChangeOptions); - OP4( REVERSE, 2); - INVOKE( RETURN_STK); + FWDLABEL( dontChangeOptions); + OP4( REVERSE, 2); + INVOKE( RETURN_STK); } - JUMP4( JUMP, addrsToFix[i]); + FWDJUMP( JUMP, addrsToFix[i]); if (matchClauses[i]) { - FIXJUMP4( notECJumpSource); + FWDLABEL( notECJumpSource); } - FIXJUMP4( notCodeJumpSource); + FWDLABEL( notCodeJumpSource); } /* @@ -3180,10 +3148,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 @@ -3191,12 +3159,12 @@ IssueTryClausesInstructions( */ if (!trapZero) { - FIXJUMP4( afterBody); + FWDLABEL( afterBody); } for (i=0 ; i= 0 || handlerTokens[i]) { range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); - OP4( BEGIN_CATCH4, range); + OP4( BEGIN_CATCH, range); ExceptionRangeStarts(envPtr, range); } if (resultVars[i] >= 0) { - LOAD( resultVar); - STORE( resultVars[i]); - OP( POP); + OP4( LOAD_SCALAR, resultVar); + OP4( STORE_SCALAR, resultVars[i]); + OP( POP); if (optionVars[i] >= 0) { - LOAD( optionsVar); - STORE( optionVars[i]); - OP( POP); + OP4( LOAD_SCALAR, optionsVar); + OP4( STORE_SCALAR, optionVars[i]); + OP( POP); } if (!handlerTokens[i]) { @@ -3353,9 +3321,9 @@ 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]) { @@ -3365,7 +3333,7 @@ IssueTryClausesFinallyInstructions( */ forwardsNeedFixing = 1; - JUMP4( JUMP, forwardsToFix[i]); + FWDJUMP( JUMP, forwardsToFix[i]); goto endOfThisArm; } @@ -3378,23 +3346,23 @@ IssueTryClausesFinallyInstructions( if (forwardsNeedFixing) { int bodyStart; forwardsNeedFixing = 0; - JUMP4( JUMP, bodyStart); + FWDJUMP( JUMP, bodyStart); for (j=0 ; jatCmdStart &= ~1; - LABEL(testCodeOffset); + BACKLABEL( testCodeOffset); } /* * Compile the loop body. */ - bodyCodeOffset = ExceptionRangeStarts(envPtr, range); + BACKLABEL( bodyCodeOffset); if (!loopMayEnd) { envPtr->exceptArrayPtr[range].continueOffset = testCodeOffset; envPtr->exceptArrayPtr[range].codeOffset = bodyCodeOffset; } - BODY(bodyTokenPtr, 2); - ExceptionRangeEnds(envPtr, range); - OP( POP); + CATCH_RANGE(range) { + BODY( bodyTokenPtr, 2); + } + OP( POP); /* * Compile the test expression then emit the conditional jump that @@ -3851,13 +3818,13 @@ TclCompileWhileCmd( */ if (loopMayEnd) { - TclFixupForwardJumpToHere(envPtr, &jumpEvalCondFixup); + FWDLABEL( jumpEvalCond); SetLineInformation(1); TclCompileExprWords(interp, testTokenPtr, 1, envPtr); - BACKJUMP4(JUMP_TRUE, bodyCodeOffset); + BACKJUMP( JUMP_TRUE, bodyCodeOffset); } else { - BACKJUMP4(JUMP, bodyCodeOffset); + BACKJUMP( JUMP, bodyCodeOffset); } /* @@ -3916,7 +3883,7 @@ TclCompileYieldCmd( CompileWord(envPtr, valueTokenPtr, interp, 1); } - OP( YIELD); + INVOKE( YIELD); return TCL_OK; } @@ -3954,13 +3921,13 @@ TclCompileYieldToCmd( return TCL_ERROR; } - OP( NS_CURRENT); + OP( NS_CURRENT); for (i = 1 ; i < (int)parsePtr->numWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } - OP4( LIST, i); - OP( YIELD_TO_INVOKE); + OP4( LIST, i); + INVOKE( YIELD_TO_INVOKE); return TCL_OK; } @@ -4050,7 +4017,7 @@ CompileAssociativeBinaryOpCmd( * calculations, including roundoff errors. */ - OP4( REVERSE, words-1); + OP4( REVERSE, words - 1); } while (--words > 1) { TclEmitOpcode(instruction, envPtr); @@ -4121,7 +4088,7 @@ CompileComparisonOpCmd( /* TODO: Consider support for compiling expanded args. */ if ((int)parsePtr->numWords < 3) { - PUSH("1"); + PUSH( "1"); } else if (parsePtr->numWords == 3) { tokenPtr = TokenAfter(parsePtr->tokenPtr); CompileWord(envPtr, tokenPtr, interp, 1); @@ -4142,19 +4109,19 @@ CompileComparisonOpCmd( CompileWord(envPtr, tokenPtr, interp, 1); tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 2); - STORE(tmpIndex); + OP4( STORE_SCALAR, tmpIndex); TclEmitOpcode(instruction, envPtr); for (words=3 ; wordsnumWords ;) { - LOAD(tmpIndex); + OP4( LOAD_SCALAR, tmpIndex); tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, words); if (++words < parsePtr->numWords) { - STORE(tmpIndex); + OP4( STORE_SCALAR, tmpIndex); } TclEmitOpcode(instruction, envPtr); } for (; words>3 ; words--) { - OP( BITAND); + OP( BITAND); } /* @@ -4162,7 +4129,7 @@ CompileComparisonOpCmd( * might be expensive elsewhere. */ - OP14( UNSET_SCALAR, 0, tmpIndex); + OP14( UNSET_SCALAR, 0, tmpIndex); } return TCL_OK; } @@ -4288,7 +4255,7 @@ TclCompilePowOpCmd( words++; } while (--words > 1) { - TclEmitOpcode(INST_EXPON, envPtr); + OP( EXPON); } return TCL_OK; } @@ -4488,11 +4455,11 @@ TclCompileMinusOpCmd( CompileWord(envPtr, tokenPtr, interp, 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; } @@ -4501,10 +4468,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); + OP4( REVERSE, 2); + OP( SUB); } return TCL_OK; } @@ -4536,7 +4503,7 @@ TclCompileDivOpCmd( CompileWord(envPtr, tokenPtr, interp, words); } if (words <= 3) { - TclEmitOpcode(INST_DIV, envPtr); + OP( DIV); return TCL_OK; } @@ -4545,10 +4512,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); + OP4( REVERSE, 2); + OP( DIV); } return TCL_OK; } diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index e4433ff..a39ab07 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -2268,7 +2268,7 @@ ExecConstantExprTree( TclInitCompileEnv(interp, envPtr, NULL, 0, NULL, 0); CompileExprTree(interp, nodes, index, litObjvPtr, NULL, NULL, envPtr, 0 /* optimize */); - TclEmitOpcode(INST_DONE, envPtr); + TclEmitOpcode( INST_DONE, envPtr); byteCodePtr = TclInitByteCode(envPtr); TclFreeCompileEnv(envPtr); TclStackFree(interp, envPtr); @@ -2393,7 +2393,7 @@ CompileExprTree( case START: case QUESTION: if (convert && (nodePtr == rootPtr)) { - TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr); + TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr); } break; case OPEN_PAREN: @@ -2406,7 +2406,7 @@ CompileExprTree( * command with the correct number of arguments. */ - TclEmitInvoke(envPtr, INST_INVOKE_STK4, numWords); + TclEmitInvoke(envPtr, INST_INVOKE_STK, numWords); /* * Restore any saved numWords value. @@ -2428,7 +2428,7 @@ CompileExprTree( jumpPtr->jump.jumpType = TCL_UNCONDITIONAL_JUMP; convert = 1; } - target = jumpPtr->jump.codeOffset + 2; + target = jumpPtr->jump.codeOffset + 5; TclFixupForwardJumpToHere(envPtr, &jumpPtr->jump); freePtr = jumpPtr; jumpPtr = jumpPtr->next; diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 0fdbf01..fc4bae0 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -13,6 +13,7 @@ */ #include "tclInt.h" +#define ALLOW_DEPRECATED_OPCODES #include "tclCompile.h" #include @@ -383,16 +384,16 @@ InstructionDesc const tclInstructionTable[] = { * Other non-OK: +9 */ - {"unsetScalar", 6, 0, 2, {OPERAND_UINT1, OPERAND_LVT4}}, + {"unsetScalar", 6, 0, 2, {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}}, + {"unsetArray", 6, -1, 2, {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}}, + {"unsetArrayStk", 2, -2, 1, {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}}, + {"unsetStk", 2, -1, 1, {OPERAND_UNSF1}}, /* Make general variable cease to exist; unparsed variable name is * stktop; op1 is 1 for errors on problems, 0 otherwise */ @@ -507,7 +508,7 @@ InstructionDesc const tclInstructionTable[] = { {"invokeReplace", 6, INT_MIN, 2, {OPERAND_UINT4,OPERAND_UINT1}}, /* Invoke command named objv[0], replacing the first two words with - * the word at the top of the stack; + * the op1 words at the top of the stack; * = */ {"listConcat", 1, -1, 0, {OPERAND_NONE}}, @@ -636,7 +637,7 @@ InstructionDesc const tclInstructionTable[] = { /* Lappend list to general variable. * Stack: ... varName list => ... listVarContents */ - {"clockRead", 2, +1, 1, {OPERAND_UINT1}}, + {"clockRead", 2, +1, 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 */ @@ -657,7 +658,7 @@ InstructionDesc const tclInstructionTable[] = { /* String Less or equal: push (stknext <= stktop) */ {"strge", 1, -1, 0, {OPERAND_NONE}}, /* String Greater or equal: push (stknext >= stktop) */ - {"lreplace", 6, INT_MIN, 2, {OPERAND_UINT4, OPERAND_UINT1}}, + {"lreplace", 6, INT_MIN, 2, {OPERAND_UINT4, OPERAND_LRPL1}}, /* Operands: number of arguments, flags * flags: Combination of TCL_LREPLACE4_* flags * Stack: ... listobj index1 ?index2? new1 ... newN => ... newlistobj @@ -672,7 +673,7 @@ InstructionDesc const tclInstructionTable[] = { /* Create constant. Variable name and value on stack. * Stack: ... varName value => ... */ - {"returnCodeBranch", 1, -1, 0, {OPERAND_NONE}}, + {"returnCodeBranch", 1, -1, 0, {OPERAND_NONE}}, /* Jump to next instruction based on the return code on top of stack * ERROR: +1; RETURN: +6; BREAK: +11; CONTINUE: +16; * Other non-OK: +21 @@ -686,6 +687,23 @@ InstructionDesc const tclInstructionTable[] = { {"incrArrayImm", 6, 0, 2, {OPERAND_LVT4, OPERAND_INT1}}, /* Incr array elem; array at slot op1, elem is stktop, * amount is 2nd operand byte */ + {"tailcall", 5, INT_MIN, 1, {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. */ + {"tclooNext", 5, INT_MIN, 1, {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 */ + {"tclooNextClass", 5, INT_MIN, 1, {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 */ {NULL, 0, 0, 0, {OPERAND_NONE}} }; @@ -848,7 +866,7 @@ TclSetByteCodeFromAny( * Compilation succeeded. Add a "done" instruction at the end. */ - TclEmitOpcode(INST_DONE, &compEnv); + TclEmitOpcode( INST_DONE, &compEnv); /* * Check for optimizations! @@ -871,7 +889,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); } @@ -896,7 +914,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? @@ -1223,7 +1241,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; @@ -1366,7 +1384,7 @@ CompileSubstObj( TclSubstCompile(interp, bytes, numBytes, flags, 1, &compEnv); - TclEmitOpcode(INST_DONE, &compEnv); + TclEmitOpcode( INST_DONE, &compEnv); codePtr = TclInitByteCodeObj(objPtr, &substCodeType, &compEnv); TclFreeCompileEnv(&compEnv); @@ -1890,7 +1908,7 @@ TclCompileInvocation( TclEmitPush(objIdx, envPtr); } - TclEmitInvoke(envPtr, INST_INVOKE_STK4, wordIdx); + TclEmitInvoke(envPtr, INST_INVOKE_STK, wordIdx); TclCheckStackDepth(depth+1, envPtr); } @@ -1921,8 +1939,8 @@ 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); + TclEmitInstInt4(INST_EXPAND_STKTOP, envPtr->currStackDepth, + envPtr); } continue; } @@ -1982,13 +2000,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; + TclEmitInstInt44( INST_START_CMD, 0, 0, envPtr); break; case 1: if (envPtr->codeNext > envPtr->codeStart) { - incrOffset = envPtr->codeNext - 4 - envPtr->codeStart; + incrOffset = CurrentOffset(envPtr) - 4; } break; case 2: @@ -2054,7 +2071,7 @@ CompileCommandTokens( Tcl_Size cmdLine = envPtr->line; Tcl_Size *clNext = envPtr->clNext; Tcl_Size cmdIdx = envPtr->numCommands; - Tcl_Size startCodeOffset = envPtr->codeNext - envPtr->codeStart; + Tcl_Size startCodeOffset = CurrentOffset(envPtr); int depth = TclGetStackDepth(envPtr); assert ((int)parsePtr->numWords > 0); @@ -2131,10 +2148,10 @@ CompileCommandTokens( Tcl_DecrRefCount(cmdObj); - TclEmitOpcode(INST_POP, envPtr); + TclEmitOpcode( INST_POP, envPtr); 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 @@ -2408,16 +2425,16 @@ TclCompileVarSubst( if (tokenPtr->numComponents == 1) { if (localVar < 0) { - TclEmitOpcode(INST_LOAD_STK, envPtr); + TclEmitOpcode( INST_LOAD_STK, envPtr); } else { - TclEmitInstInt4(INST_LOAD_SCALAR4, localVar, envPtr); + TclEmitInstInt4( INST_LOAD_SCALAR, localVar, envPtr); } } else { TclCompileTokens(interp, tokenPtr+2, tokenPtr->numComponents-1, envPtr); if (localVar < 0) { - TclEmitOpcode(INST_LOAD_ARRAY_STK, envPtr); + TclEmitOpcode( INST_LOAD_ARRAY_STK, envPtr); } else { - TclEmitInstInt4(INST_LOAD_ARRAY4, localVar, envPtr); + TclEmitInstInt4( INST_LOAD_ARRAY, localVar, envPtr); } } } @@ -2592,11 +2609,11 @@ TclCompileTokens( */ while (numObjsToConcat > 255) { - TclEmitInstInt1(INST_STR_CONCAT1, 255, envPtr); + TclEmitInstInt1( INST_STR_CONCAT1, 255, envPtr); numObjsToConcat -= 254; /* concat pushes 1 obj, the result */ } if (numObjsToConcat > 1) { - TclEmitInstInt1(INST_STR_CONCAT1, numObjsToConcat, envPtr); + TclEmitInstInt1( INST_STR_CONCAT1, numObjsToConcat, envPtr); } /* @@ -2728,13 +2745,13 @@ TclCompileExprWords( } concatItems = 2*numWords - 1; while (concatItems > 255) { - TclEmitInstInt1(INST_STR_CONCAT1, 255, envPtr); + TclEmitInstInt1( INST_STR_CONCAT1, 255, envPtr); concatItems -= 254; } if (concatItems > 1) { - TclEmitInstInt1(INST_STR_CONCAT1, concatItems, envPtr); + TclEmitInstInt1( INST_STR_CONCAT1, concatItems, envPtr); } - TclEmitOpcode(INST_EXPR_STK, envPtr); + TclEmitOpcode( INST_EXPR_STK, envPtr); } /* @@ -2772,7 +2789,7 @@ TclCompileNoOp( if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { CompileTokens(envPtr, tokenPtr, interp); - TclEmitOpcode(INST_POP, envPtr); + TclEmitOpcode( INST_POP, envPtr); } } PushStringLiteral(envPtr, ""); @@ -2859,7 +2876,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); @@ -3157,7 +3174,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) { @@ -3524,7 +3541,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. * * --------------------------------------------------------------------- @@ -3553,7 +3570,7 @@ TclAddLoopBreakFixup( } } auxPtr->breakTargets[auxPtr->numBreakTargets - 1] = CurrentOffset(envPtr); - TclEmitInstInt4(INST_JUMP4, 0, envPtr); + TclEmitInstInt4( INST_JUMP, 0, envPtr); } void @@ -3580,7 +3597,7 @@ TclAddLoopContinueFixup( } auxPtr->continueTargets[auxPtr->numContinueTargets - 1] = CurrentOffset(envPtr); - TclEmitInstInt4(INST_JUMP4, 0, envPtr); + TclEmitInstInt4( INST_JUMP, 0, envPtr); } /* @@ -3605,7 +3622,7 @@ TclCleanupStackForBreakContinue( if (toPop > 0) { while (toPop --> 0) { - TclEmitOpcode(INST_EXPAND_DROP, envPtr); + TclEmitOpcode( INST_EXPAND_DROP, envPtr); } TclAdjustStackDepth((int)(auxPtr->expandTargetDepth - envPtr->currStackDepth), envPtr); @@ -3613,7 +3630,7 @@ TclCleanupStackForBreakContinue( } toPop = envPtr->currStackDepth - auxPtr->stackDepth; while (toPop --> 0) { - TclEmitOpcode(INST_POP, envPtr); + TclEmitOpcode( INST_POP, envPtr); } envPtr->currStackDepth = savedStackDepth; } @@ -3636,7 +3653,7 @@ StartExpanding( { int i; - TclEmitOpcode(INST_EXPAND_START, envPtr); + TclEmitOpcode( INST_EXPAND_START, envPtr); /* * Update inner exception ranges with information about the environment @@ -3703,14 +3720,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++) { 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]; @@ -3728,7 +3745,7 @@ TclFinalizeLoopExceptionRange( } } else { offset = rangePtr->continueOffset - auxPtr->continueTargets[i]; - TclUpdateInstInt4AtPc(INST_JUMP4, offset, site); + TclUpdateInstInt4AtPc(INST_JUMP, offset, site); } } @@ -3964,19 +3981,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: - TclEmitInstInt4(INST_JUMP4, 0, envPtr); + TclEmitInstInt4( INST_JUMP, 0, envPtr); break; case TCL_TRUE_JUMP: - TclEmitInstInt4(INST_JUMP_TRUE4, 0, envPtr); + TclEmitInstInt4( INST_JUMP_TRUE, 0, envPtr); break; default: // TCL_FALSE_JUMP - TclEmitInstInt4(INST_JUMP_FALSE4, 0, envPtr); + TclEmitInstInt4( INST_JUMP_FALSE, 0, envPtr); break; } } @@ -3991,7 +4008,7 @@ TclEmitForwardJump( * previously initialized by TclEmitForwardJump. * * Results: - * Always 0. + * None * * Side effects: * None @@ -4011,16 +4028,15 @@ TclFixupForwardJump( 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: // TCL_FALSE_JUMP - TclUpdateInstInt4AtPc(INST_JUMP_FALSE4, jumpDist, jumpPc); + TclUpdateInstInt4AtPc( INST_JUMP_FALSE, jumpDist, jumpPc); break; } - return 0; } /* @@ -4033,6 +4049,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 * @@ -4063,11 +4081,15 @@ TclEmitInvoke( va_start(argList, opcode); switch (opcode) { + 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: + case INST_TCLOO_NEXT: + case INST_TCLOO_NEXT_CLASS: + case INST_INVOKE_STK: wordCount = arg1 = cleanup = va_arg(argList, int); arg2 = 0; break; @@ -4077,8 +4099,8 @@ 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: wordCount = cleanup = 1; arg1 = arg2 = 0; @@ -4092,6 +4114,9 @@ TclEmitInvoke( arg2 = 0; expandCount = 1; break; + default: + Tcl_Panic("opcode %s not handled by TclEmitInvoke()", + tclInstructionTable[opcode].name); } va_end(argList); @@ -4136,27 +4161,47 @@ TclEmitInvoke( switch (opcode) { case INST_INVOKE_STK1: - TclEmitInstInt1(INST_INVOKE_STK1, arg1, envPtr); + TclEmitInstInt1( INST_INVOKE_STK1, arg1, envPtr); break; - case INST_INVOKE_STK4: - TclEmitInstInt4(INST_INVOKE_STK4, arg1, envPtr); + case INST_INVOKE_STK: + TclEmitInstInt4( INST_INVOKE_STK, arg1, envPtr); break; case INST_INVOKE_EXPANDED: - TclEmitOpcode(INST_INVOKE_EXPANDED, envPtr); + TclEmitOpcode( INST_INVOKE_EXPANDED, envPtr); envPtr->expandCount--; TclAdjustStackDepth(1 - arg1, envPtr); break; case INST_EVAL_STK: - TclEmitOpcode(INST_EVAL_STK, envPtr); + TclEmitOpcode( INST_EVAL_STK, envPtr); break; case INST_RETURN_STK: - TclEmitOpcode(INST_RETURN_STK, envPtr); + TclEmitOpcode( INST_RETURN_STK, envPtr); break; case INST_INVOKE_REPLACE: - TclEmitInstInt4(INST_INVOKE_REPLACE, arg1, envPtr); - TclEmitInt1(arg2, envPtr); + TclEmitInstInt41( INST_INVOKE_REPLACE, arg1, arg2, envPtr); TclAdjustStackDepth(-1, envPtr); /* Correction to stack depth calcs */ break; + case INST_TCLOO_NEXT1: + TclEmitInstInt1( INST_TCLOO_NEXT1, arg1, envPtr); + break; + case INST_TCLOO_NEXT_CLASS1: + TclEmitInstInt1( INST_TCLOO_NEXT_CLASS1, arg1, envPtr); + break; + case INST_TCLOO_NEXT: + TclEmitInstInt4( INST_TCLOO_NEXT, arg1, envPtr); + break; + case INST_TCLOO_NEXT_CLASS: + TclEmitInstInt4( INST_TCLOO_NEXT_CLASS, arg1, envPtr); + break; + case INST_YIELD: + TclEmitOpcode( INST_YIELD, envPtr); + break; + case INST_YIELD_TO_INVOKE: + TclEmitOpcode( INST_YIELD_TO_INVOKE, envPtr); + break; + default: + Tcl_Panic("opcode %s not handled by TclEmitInvoke()", + tclInstructionTable[opcode].name); } /* diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 3e2b97d..1b611a1 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -135,7 +135,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. */ - size_t *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 +145,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. */ - size_t *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 @@ -560,28 +559,28 @@ enum TclInstruction { /* Opcodes 0 to 9 */ INST_DONE = 0, DEPRECATED_OPCODE(INST_PUSH1), - INST_PUSH4, + INST_PUSH, INST_POP, INST_DUP, INST_STR_CONCAT1, DEPRECATED_OPCODE(INST_INVOKE_STK1), - INST_INVOKE_STK4, + INST_INVOKE_STK, INST_EVAL_STK, INST_EXPR_STK, /* Opcodes 10 to 23 */ DEPRECATED_OPCODE(INST_LOAD_SCALAR1), - INST_LOAD_SCALAR4, + INST_LOAD_SCALAR, INST_LOAD_SCALAR_STK, DEPRECATED_OPCODE(INST_LOAD_ARRAY1), - INST_LOAD_ARRAY4, + INST_LOAD_ARRAY, INST_LOAD_ARRAY_STK, INST_LOAD_STK, DEPRECATED_OPCODE(INST_STORE_SCALAR1), - INST_STORE_SCALAR4, + INST_STORE_SCALAR, INST_STORE_SCALAR_STK, DEPRECATED_OPCODE(INST_STORE_ARRAY1), - INST_STORE_ARRAY4, + INST_STORE_ARRAY, INST_STORE_ARRAY_STK, INST_STORE_STK, @@ -599,11 +598,11 @@ enum TclInstruction { /* Opcodes 34 to 39 */ DEPRECATED_OPCODE(INST_JUMP1), - INST_JUMP4, + INST_JUMP, DEPRECATED_OPCODE(INST_JUMP_TRUE1), - INST_JUMP_TRUE4, + INST_JUMP_TRUE, DEPRECATED_OPCODE(INST_JUMP_FALSE1), - INST_JUMP_FALSE4, + INST_JUMP_FALSE, /* Opcodes 42 to 64 */ INST_BITOR, @@ -633,7 +632,7 @@ enum TclInstruction { INST_CONTINUE, /* Opcodes 69 to 72 */ - INST_BEGIN_CATCH4, + INST_BEGIN_CATCH, INST_END_CATCH, INST_PUSH_RESULT, INST_PUSH_RETURN_CODE, @@ -653,17 +652,17 @@ enum TclInstruction { /* Opcodes 82 to 87 */ DEPRECATED_OPCODE(INST_APPEND_SCALAR1), - INST_APPEND_SCALAR4, + INST_APPEND_SCALAR, DEPRECATED_OPCODE(INST_APPEND_ARRAY1), - INST_APPEND_ARRAY4, + INST_APPEND_ARRAY, INST_APPEND_ARRAY_STK, INST_APPEND_STK, /* Opcodes 88 to 93 */ DEPRECATED_OPCODE(INST_LAPPEND_SCALAR1), - INST_LAPPEND_SCALAR4, + INST_LAPPEND_SCALAR, DEPRECATED_OPCODE(INST_LAPPEND_ARRAY1), - INST_LAPPEND_ARRAY4, + INST_LAPPEND_ARRAY, INST_LAPPEND_ARRAY_STK, INST_LAPPEND_STK, @@ -771,7 +770,7 @@ 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, @@ -817,8 +816,8 @@ 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, @@ -841,18 +840,21 @@ enum TclInstruction { INST_STR_LE, INST_STR_GE, - INST_LREPLACE4, + INST_LREPLACE, /* TIP 667: const */ INST_CONST_IMM, INST_CONST_STK, - /* Updated [subst] and [incr] compilation */ - INST_RETURN_CODE_BRANCH4, - INST_INCR_SCALAR4, - INST_INCR_ARRAY4, - INST_INCR_SCALAR4_IMM, - INST_INCR_ARRAY4_IMM, + /* Updated compilations with fewer arg size constraints */ + INST_RETURN_CODE_BRANCH, + INST_INCR_SCALAR, + INST_INCR_ARRAY, + INST_INCR_SCALAR_IMM, + INST_INCR_ARRAY_IMM, + INST_TAILCALL, + INST_TCLOO_NEXT, + INST_TCLOO_NEXT_CLASS, /* The last opcode */ LAST_INST_OPCODE @@ -889,7 +891,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_LREPLACE4_* flags. */ } InstOperandType; typedef struct InstructionDesc { @@ -1343,25 +1348,23 @@ TclUpdateStackReqs( #define TclEmitInt1(i, envPtr) \ do { \ + unsigned tcl_i = (unsigned) (i); \ if ((envPtr)->codeNext == (envPtr)->codeEnd) { \ TclExpandCodeArray(envPtr); \ } \ - *(envPtr)->codeNext++ = (unsigned char) ((unsigned int) (i)); \ + *(envPtr)->codeNext++ = (unsigned char) tcl_i; \ } while (0) #define TclEmitInt4(i, envPtr) \ do { \ + unsigned tcl_i = (unsigned) (i); \ 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) ); \ + *(envPtr)->codeNext++ = (unsigned char) (tcl_i >> 24); \ + *(envPtr)->codeNext++ = (unsigned char) (tcl_i >> 16); \ + *(envPtr)->codeNext++ = (unsigned char) (tcl_i >> 8); \ + *(envPtr)->codeNext++ = (unsigned char) (tcl_i ); \ } while (0) /* @@ -1376,31 +1379,80 @@ TclUpdateStackReqs( #define TclEmitInstInt1(op, i, envPtr) \ do { \ + unsigned tcl_i = (unsigned) (i); \ if (((envPtr)->codeNext + 2) > (envPtr)->codeEnd) { \ TclExpandCodeArray(envPtr); \ } \ *(envPtr)->codeNext++ = (unsigned char) (op); \ - *(envPtr)->codeNext++ = (unsigned char) ((unsigned int) (i)); \ + *(envPtr)->codeNext++ = (unsigned char) tcl_i; \ TclUpdateAtCmdStart(op, envPtr); \ - TclUpdateStackReqs(op, i, envPtr); \ + TclUpdateStackReqs(op, tcl_i, envPtr); \ } while (0) #define TclEmitInstInt4(op, i, envPtr) \ do { \ + unsigned tcl_i = (unsigned) (i); \ 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) ); \ + *(envPtr)->codeNext++ = (unsigned char) (tcl_i >> 24); \ + *(envPtr)->codeNext++ = (unsigned char) (tcl_i >> 16); \ + *(envPtr)->codeNext++ = (unsigned char) (tcl_i >> 8); \ + *(envPtr)->codeNext++ = (unsigned char) (tcl_i ); \ TclUpdateAtCmdStart(op, envPtr); \ - TclUpdateStackReqs(op, i, envPtr); \ + TclUpdateStackReqs(op, tcl_i, envPtr); \ + } while (0) + +#define TclEmitInstInt14(op, i, j, envPtr) \ + do { \ + unsigned tcl_i = (unsigned) (i), tcl_j = (unsigned) (j); \ + if (((envPtr)->codeNext + 6) > (envPtr)->codeEnd) { \ + TclExpandCodeArray(envPtr); \ + } \ + *(envPtr)->codeNext++ = (unsigned char) (op); \ + *(envPtr)->codeNext++ = (unsigned char) tcl_i; \ + *(envPtr)->codeNext++ = (unsigned char) (tcl_j >> 24); \ + *(envPtr)->codeNext++ = (unsigned char) (tcl_j >> 16); \ + *(envPtr)->codeNext++ = (unsigned char) (tcl_j >> 8); \ + *(envPtr)->codeNext++ = (unsigned char) (tcl_j ); \ + TclUpdateAtCmdStart(op, envPtr); \ + TclUpdateStackReqs(op, tcl_i, envPtr); \ + } while (0) + +#define TclEmitInstInt41(op, i, j, envPtr) \ + do { \ + unsigned tcl_i = (unsigned) (i), tcl_j = (unsigned) (j); \ + if (((envPtr)->codeNext + 6) > (envPtr)->codeEnd) { \ + TclExpandCodeArray(envPtr); \ + } \ + *(envPtr)->codeNext++ = (unsigned char) (op); \ + *(envPtr)->codeNext++ = (unsigned char) (tcl_i >> 24); \ + *(envPtr)->codeNext++ = (unsigned char) (tcl_i >> 16); \ + *(envPtr)->codeNext++ = (unsigned char) (tcl_i >> 8); \ + *(envPtr)->codeNext++ = (unsigned char) (tcl_i ); \ + *(envPtr)->codeNext++ = (unsigned char) (tcl_j ); \ + TclUpdateAtCmdStart(op, envPtr); \ + TclUpdateStackReqs(op, tcl_i, envPtr); \ + } while (0) + +#define TclEmitInstInt44(op, i, j, envPtr) \ + do { \ + unsigned tcl_i = (unsigned) (i), tcl_j = (unsigned) (j); \ + if (((envPtr)->codeNext + 9) > (envPtr)->codeEnd) { \ + TclExpandCodeArray(envPtr); \ + } \ + *(envPtr)->codeNext++ = (unsigned char) (op); \ + *(envPtr)->codeNext++ = (unsigned char) (tcl_i >> 24); \ + *(envPtr)->codeNext++ = (unsigned char) (tcl_i >> 16); \ + *(envPtr)->codeNext++ = (unsigned char) (tcl_i >> 8); \ + *(envPtr)->codeNext++ = (unsigned char) (tcl_i ); \ + *(envPtr)->codeNext++ = (unsigned char) (tcl_j >> 24); \ + *(envPtr)->codeNext++ = (unsigned char) (tcl_j >> 16); \ + *(envPtr)->codeNext++ = (unsigned char) (tcl_j >> 8); \ + *(envPtr)->codeNext++ = (unsigned char) (tcl_j ); \ + TclUpdateAtCmdStart(op, envPtr); \ + TclUpdateStackReqs(op, tcl_i, envPtr); \ } while (0) /* @@ -1415,11 +1467,7 @@ TclUpdateStackReqs( #define TclEmitPush(objIndex, envPtr) \ do { \ int _objIndexCopy = (objIndex); \ - if (_objIndexCopy <= 255) { \ - TclEmitInstInt1(INST_PUSH1, _objIndexCopy, (envPtr)); \ - } else { \ - TclEmitInstInt4(INST_PUSH4, _objIndexCopy, (envPtr)); \ - } \ + TclEmitInstInt4(INST_PUSH, _objIndexCopy, (envPtr)); \ } while (0) /* @@ -1679,9 +1727,12 @@ 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_LARGE_INDEX 1 /* Do not return localIndex value > 255 */ #define TCL_NO_ELEMENT 2 /* Do not push the array element. */ /* diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index ffc3026..d252e35 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -647,6 +647,46 @@ FormatInstruction( 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 0: + Tcl_AppendPrintfToObj(bufferObj, "clicks " ); + break; + case 1: + Tcl_AppendPrintfToObj(bufferObj, "micros " ); + break; + case 2: + Tcl_AppendPrintfToObj(bufferObj, "millis " ); + break; + case 3: + 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_LREPLACE4_END_IS_LAST: + Tcl_AppendPrintfToObj(bufferObj, "endLast "); + break; + case TCL_LREPLACE4_SINGLE_INDEX: + Tcl_AppendPrintfToObj(bufferObj, "singleIdx "); + break; + default: + Tcl_AppendPrintfToObj(bufferObj, "endLast,singleIdx "); + break; + } + break; case OPERAND_NONE: default: break; @@ -746,7 +786,7 @@ TclGetInnerContext( objc = 2; break; - case INST_INVOKE_STK4: + case INST_INVOKE_STK: objc = TclGetUInt4AtPtr(pc+1); break; @@ -1026,6 +1066,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; diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 790f03d..adb0318 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -263,10 +263,10 @@ VarHashCreateVar( case INST_JUMP_TRUE1: \ NEXT_INST_F(((condition)? TclGetInt1AtPtr(pc+1) : 2), (cleanup), 0); \ break; \ - case INST_JUMP_FALSE4: \ + case INST_JUMP_FALSE: \ NEXT_INST_F(((condition)? 5 : TclGetInt4AtPtr(pc+1)), (cleanup), 0); \ break; \ - case INST_JUMP_TRUE4: \ + case INST_JUMP_TRUE: \ NEXT_INST_F(((condition)? TclGetInt4AtPtr(pc+1) : 5), (cleanup), 0); \ break; \ default: \ @@ -289,10 +289,10 @@ VarHashCreateVar( case INST_JUMP_TRUE1: \ NEXT_INST_V(((condition)? TclGetInt1AtPtr(pc+1) : 2), (cleanup), 0); \ break; \ - case INST_JUMP_FALSE4: \ + case INST_JUMP_FALSE: \ NEXT_INST_V(((condition)? 5 : TclGetInt4AtPtr(pc+1)), (cleanup), 0); \ break; \ - case INST_JUMP_TRUE4: \ + case INST_JUMP_TRUE: \ NEXT_INST_V(((condition)? TclGetInt4AtPtr(pc+1) : 5), (cleanup), 0); \ break; \ default: \ @@ -2281,9 +2281,9 @@ TEBCresume( TCL_DTRACE_INST_NEXT(); - if (inst == INST_LOAD_SCALAR4) { - goto instLoadScalar4; - } else if (inst == INST_PUSH4) { + 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); @@ -2477,11 +2477,15 @@ TEBCresume( return TCL_OK; } - case INST_TAILCALL: { - Tcl_Obj *listPtr; - + case INST_TAILCALL1: + DEPRECATED_OPCODE_MARK(INST_TAILCALL1); opnd = TclGetUInt1AtPtr(pc+1); + goto doTailcall; + case INST_TAILCALL: + opnd = TclGetUInt4AtPtr(pc+1); + + doTailcall: if (!(iPtr->varFramePtr->isProcCallFrame & 1)) { TRACE(("%d => ERROR: tailcall in non-proc context\n", opnd)); Tcl_SetObjResult(interp, Tcl_NewStringObj( @@ -2513,6 +2517,8 @@ TEBCresume( * stack. */ + { + Tcl_Obj *listPtr; listPtr = Tcl_NewListObj(opnd, &OBJ_AT_DEPTH(opnd-1)); TclListObjSetElement(NULL, listPtr, 0, TclNewNamespaceObj( (Tcl_Namespace *) iPtr->varFramePtr->nsPtr)); @@ -2563,7 +2569,7 @@ TEBCresume( NEXT_INST_F(2, 0, 1); break; - case INST_PUSH4: + case INST_PUSH: objResultPtr = codePtr->objArrayPtr[TclGetUInt4AtPtr(pc+1)]; TRACE_WITH_OBJ(("%u => ", TclGetUInt4AtPtr(pc+1)), objResultPtr); NEXT_INST_F(5, 0, 1); @@ -2788,7 +2794,7 @@ TEBCresume( NEXT_INST_F(1, 0, 1); break; - case INST_INVOKE_STK4: + case INST_INVOKE_STK: objc = TclGetUInt4AtPtr(pc+1); pcAdjustment = 5; goto doInvocation; @@ -2941,8 +2947,8 @@ TEBCresume( part1Ptr = part2Ptr = NULL; goto doCallPtrGetVar; - case INST_LOAD_SCALAR4: - instLoadScalar4: + case INST_LOAD_SCALAR: + instLoadScalar: opnd = TclGetUInt4AtPtr(pc+1); varPtr = LOCAL(opnd); while (TclIsVarLink(varPtr)) { @@ -2964,7 +2970,7 @@ TEBCresume( part1Ptr = part2Ptr = NULL; goto doCallPtrGetVar; - case INST_LOAD_ARRAY4: + case INST_LOAD_ARRAY: opnd = TclGetUInt4AtPtr(pc+1); pcAdjustment = 5; goto doLoadArray; @@ -3070,15 +3076,15 @@ TEBCresume( int storeFlags; Tcl_Size len; - case INST_STORE_ARRAY4: - opnd = TclGetUInt4AtPtr(pc+1); - pcAdjustment = 5; - goto doStoreArrayDirect; - case INST_STORE_ARRAY1: DEPRECATED_OPCODE_MARK(INST_STORE_ARRAY1); opnd = TclGetUInt1AtPtr(pc+1); pcAdjustment = 2; + goto doStoreArrayDirect; + + case INST_STORE_ARRAY: + opnd = TclGetUInt4AtPtr(pc+1); + pcAdjustment = 5; doStoreArrayDirect: valuePtr = OBJ_AT_TOS; @@ -3103,15 +3109,15 @@ TEBCresume( part1Ptr = NULL; goto doStoreArrayDirectFailed; - case INST_STORE_SCALAR4: - opnd = TclGetUInt4AtPtr(pc+1); - pcAdjustment = 5; - goto doStoreScalarDirect; - case INST_STORE_SCALAR1: DEPRECATED_OPCODE_MARK(INST_STORE_SCALAR1); opnd = TclGetUInt1AtPtr(pc+1); pcAdjustment = 2; + goto doStoreScalarDirect; + + case INST_STORE_SCALAR: + opnd = TclGetUInt4AtPtr(pc+1); + pcAdjustment = 5; doStoreScalarDirect: valuePtr = OBJ_AT_TOS; @@ -3210,7 +3216,7 @@ TEBCresume( opnd = -1; goto doCallPtrSetVar; - case INST_LAPPEND_ARRAY4: + case INST_LAPPEND_ARRAY: opnd = TclGetUInt4AtPtr(pc+1); pcAdjustment = 5; storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE @@ -3225,7 +3231,7 @@ TEBCresume( | TCL_LIST_ELEMENT); goto doStoreArray; - case INST_APPEND_ARRAY4: + case INST_APPEND_ARRAY: opnd = TclGetUInt4AtPtr(pc+1); pcAdjustment = 5; storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); @@ -3259,7 +3265,7 @@ TEBCresume( } goto doCallPtrSetVar; - case INST_LAPPEND_SCALAR4: + case INST_LAPPEND_SCALAR: opnd = TclGetUInt4AtPtr(pc+1); pcAdjustment = 5; storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE @@ -3274,7 +3280,7 @@ TEBCresume( | TCL_LIST_ELEMENT); goto doStoreScalar; - case INST_APPEND_SCALAR4: + case INST_APPEND_SCALAR: opnd = TclGetUInt4AtPtr(pc+1); pcAdjustment = 5; storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); @@ -3522,15 +3528,15 @@ TEBCresume( goto doIncrStk; } - case INST_INCR_SCALAR4: - case INST_INCR_ARRAY4: + case INST_INCR_SCALAR: + case INST_INCR_ARRAY: opnd = TclGetUInt4AtPtr(pc+1); incrPtr = POP_OBJECT(); pcAdjustment = 5; switch (*pc) { - case INST_INCR_SCALAR4: + case INST_INCR_SCALAR: goto doIncrScalar; - case INST_INCR_ARRAY4: + case INST_INCR_ARRAY: goto doIncrArray; default: Tcl_Panic("unknown instruction"); @@ -3572,14 +3578,6 @@ TEBCresume( cleanup = ((part2Ptr == NULL)? 1 : 2); goto doIncrVar; - case INST_INCR_ARRAY4_IMM: - opnd = TclGetUInt4AtPtr(pc+1); - increment = TclGetInt1AtPtr(pc+5); - TclNewIntObj(incrPtr, increment); - Tcl_IncrRefCount(incrPtr); - pcAdjustment = 6; - goto doIncrArray; - case INST_INCR_ARRAY1_IMM: DEPRECATED_OPCODE_MARK(INST_INCR_ARRAY1_IMM); opnd = TclGetUInt1AtPtr(pc+1); @@ -3587,6 +3585,14 @@ TEBCresume( TclNewIntObj(incrPtr, increment); Tcl_IncrRefCount(incrPtr); pcAdjustment = 3; + goto doIncrArray; + + case INST_INCR_ARRAY_IMM: + opnd = TclGetUInt4AtPtr(pc+1); + increment = TclGetInt1AtPtr(pc+5); + TclNewIntObj(incrPtr, increment); + Tcl_IncrRefCount(incrPtr); + pcAdjustment = 6; doIncrArray: part1Ptr = NULL; @@ -3606,15 +3612,16 @@ TEBCresume( } goto doIncrVar; - case INST_INCR_SCALAR4_IMM: - opnd = TclGetUInt4AtPtr(pc+1); - increment = TclGetInt1AtPtr(pc+5); - pcAdjustment = 6; - goto doIncrScalarImm; case INST_INCR_SCALAR1_IMM: + DEPRECATED_OPCODE_MARK(INST_INCR_SCALAR1_IMM); opnd = TclGetUInt1AtPtr(pc+1); increment = TclGetInt1AtPtr(pc+2); pcAdjustment = 3; + goto doIncrScalarImm; + case INST_INCR_SCALAR_IMM: + opnd = TclGetUInt4AtPtr(pc+1); + increment = TclGetInt1AtPtr(pc+5); + pcAdjustment = 6; doIncrScalarImm: cleanup = 0; varPtr = LOCAL(opnd); @@ -4276,7 +4283,7 @@ TEBCresume( (size_t)(pc + opnd - codePtr->codeStart))); NEXT_INST_F(opnd, 0, 0); - case INST_JUMP4: + case INST_JUMP: opnd = TclGetInt4AtPtr(pc+1); TRACE(("%d => new pc %" TCL_Z_MODIFIER "u\n", opnd, (size_t)(pc + opnd - codePtr->codeStart))); @@ -4287,16 +4294,6 @@ TEBCresume( /* 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; - case INST_JUMP_FALSE1: DEPRECATED_OPCODE_MARK(INST_JUMP_FALSE1); jmpOffset[0] = TclGetInt1AtPtr(pc+1); @@ -4307,11 +4304,21 @@ TEBCresume( DEPRECATED_OPCODE_MARK(INST_JUMP_TRUE1); jmpOffset[0] = 2; jmpOffset[1] = TclGetInt1AtPtr(pc+1); + goto doCondJump; + + case INST_JUMP_FALSE: + jmpOffset[0] = TclGetInt4AtPtr(pc+1); /* FALSE offset */ + jmpOffset[1] = 5; /* TRUE offset */ + goto doCondJump; + + case INST_JUMP_TRUE: + jmpOffset[0] = 5; + jmpOffset[1] = TclGetInt4AtPtr(pc+1); doCondJump: valuePtr = OBJ_AT_TOS; TRACE(("%d => ", jmpOffset[ - (*pc==INST_JUMP_FALSE1 || *pc==INST_JUMP_FALSE4) ? 0 : 1])); + (*pc==INST_JUMP_FALSE1 || *pc==INST_JUMP_FALSE) ? 0 : 1])); /* TODO - check claim that taking address of b harms performance */ /* TODO - consider optimization search for constants */ @@ -4322,14 +4329,14 @@ TEBCresume( #ifdef TCL_COMPILE_DEBUG if (b) { - if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE4)) { + if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE)) { TRACE_APPEND(("%.20s true, new pc %" TCL_Z_MODIFIER "u\n", O2S(valuePtr), (size_t)(pc + jmpOffset[1] - codePtr->codeStart))); } else { TRACE_APPEND(("%.20s true\n", O2S(valuePtr))); } } else { - if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE4)) { + if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE)) { TRACE_APPEND(("%.20s false\n", O2S(valuePtr))); } else { TRACE_APPEND(("%.20s false, new pc %" TCL_Z_MODIFIER "u\n", O2S(valuePtr), @@ -4500,8 +4507,15 @@ TEBCresume( TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(1, 0, 1); - case INST_TCLOO_NEXT_CLASS: + case INST_TCLOO_NEXT_CLASS1: + DEPRECATED_OPCODE_MARK(INST_TCLOO_NEXT_CLASS1); opnd = TclGetUInt1AtPtr(pc+1); + pcAdjustment = 2; + goto invokeNextClass; + case INST_TCLOO_NEXT_CLASS: + opnd = TclGetUInt4AtPtr(pc+1); + pcAdjustment = 5; + invokeNextClass: framePtr = iPtr->varFramePtr; valuePtr = OBJ_AT_DEPTH(opnd - 2); objv = &OBJ_AT_DEPTH(opnd - 1); @@ -4599,8 +4613,15 @@ TEBCresume( goto gotError; } - case INST_TCLOO_NEXT: + case INST_TCLOO_NEXT1: + DEPRECATED_OPCODE_MARK(INST_TCLOO_NEXT1); opnd = TclGetUInt1AtPtr(pc+1); + pcAdjustment = 2; + goto invokeNext; + case INST_TCLOO_NEXT: + opnd = TclGetUInt4AtPtr(pc+1); + pcAdjustment = 5; + invokeNext: objv = &OBJ_AT_DEPTH(opnd - 1); framePtr = iPtr->varFramePtr; skip = 1; @@ -4671,7 +4692,6 @@ TEBCresume( ArgumentBCEnter(interp, codePtr, TD, pc, opnd, objv); } - pcAdjustment = 2; cleanup = opnd; DECACHE_STACK_INFO(); iPtr->varFramePtr = framePtr->callerVarPtr; @@ -5206,7 +5226,7 @@ TEBCresume( NEXT_INST_F(1, 1, 0); } - case INST_LREPLACE4: { + case INST_LREPLACE: { size_t numToDelete, numNewElems; int end_indicator; int haveSecondIndex, flags; @@ -6741,7 +6761,7 @@ TEBCresume( } 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 @@ -6810,7 +6830,7 @@ TEBCresume( NEXT_INST_F(2*code-1, 1, 0); } - case INST_RETURN_CODE_BRANCH4: { + case INST_RETURN_CODE_BRANCH: { int code; if (TclGetIntFromObj(NULL, OBJ_AT_TOS, &code) != TCL_OK) { @@ -7543,7 +7563,7 @@ TEBCresume( opnd = TclGetUInt1AtPtr(pc+1); TRACE(("%u => ... after \"%.20s\": ", opnd, cmdNameBuf)); break; - case INST_INVOKE_STK4: + case INST_INVOKE_STK: opnd = TclGetUInt4AtPtr(pc+1); TRACE(("%u => ... after \"%.20s\": ", opnd, cmdNameBuf)); break; diff --git a/generic/tclOptimize.c b/generic/tclOptimize.c index a885438..b6c7fe4 100644 --- a/generic/tclOptimize.c +++ b/generic/tclOptimize.c @@ -85,13 +85,13 @@ LocateTargetAddresses( case INST_JUMP_FALSE1: targetInstPtr = currentInstPtr+TclGetInt1AtPtr(currentInstPtr+1); goto storeTarget; - case INST_JUMP4: - case INST_JUMP_TRUE4: - case INST_JUMP_FALSE4: + 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: @@ -112,7 +112,7 @@ LocateTargetAddresses( DefineTargetAddress(tablePtr, currentInstPtr + 2*i - 1); } break; - case INST_RETURN_CODE_BRANCH4: + case INST_RETURN_CODE_BRANCH: for (i=TCL_ERROR ; i Date: Sat, 29 Mar 2025 09:23:17 +0000 Subject: Most tests working, but not yet all. --- generic/tclCompCmds.c | 29 ++++------ generic/tclCompCmdsGR.c | 4 +- generic/tclCompCmdsSZ.c | 143 ++++++++++++++++++++++-------------------------- generic/tclCompile.h | 16 ++++++ 4 files changed, 96 insertions(+), 96 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 70a2603..841ebca 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -365,8 +365,9 @@ TclCompileArraySetCmd( FWDJUMP( JUMP_TRUE, haveArray); OP( ARRAY_MAKE_STK); FWDJUMP( JUMP, arrayMade); + /* Each branch decrements stack depth, but we only take one. */ - TclAdjustStackDepth(1, envPtr); + STKDELTA(+1); FWDLABEL( haveArray); OP( POP); FWDLABEL( arrayMade); @@ -433,7 +434,7 @@ TclCompileArraySetCmd( PUSH( "list must have an even number of elements"); PUSH( "-errorcode {TCL ARGUMENT FORMAT}"); OP44( RETURN_IMM, TCL_ERROR, 0); - TclAdjustStackDepth(-1, envPtr); + STKDELTA(-1); FWDLABEL( ok); } @@ -446,7 +447,7 @@ TclCompileArraySetCmd( infoPtr->loopCtTemp = offsetBack - CurrentOffset(envPtr); /*misuse */ OP( FOREACH_STEP); OP( FOREACH_END); - TclAdjustStackDepth(-3, envPtr); + STKDELTA(-3); PUSH( ""); done: @@ -489,8 +490,9 @@ TclCompileArrayUnsetCmd( FWDJUMP( JUMP_FALSE, noSuchArray); OP1( UNSET_STK, 1); FWDJUMP( JUMP, end); + /* Each branch decrements stack depth, but we only take one. */ - TclAdjustStackDepth(1, envPtr); + STKDELTA(+1); FWDLABEL( noSuchArray); OP( POP); FWDLABEL( end); @@ -551,7 +553,7 @@ TclCompileBreakCmd( OP( BREAK); } - TclAdjustStackDepth(1, envPtr); + STKDELTA(+1); return TCL_OK; } @@ -1051,7 +1053,7 @@ TclCompileContinueCmd( OP( CONTINUE); } - TclAdjustStackDepth(1, envPtr); + STKDELTA(+1); return TCL_OK; } @@ -1122,7 +1124,6 @@ TclCompileDictSetCmd( */ OP44( DICT_SET, numWords - 3, dictVarIndex); - TclAdjustStackDepth(-1, envPtr); return TCL_OK; } @@ -1230,7 +1231,6 @@ TclCompileDictGetCmd( tokenPtr = TokenAfter(tokenPtr); } OP4( DICT_GET, numWords - 2); - TclAdjustStackDepth(-1, envPtr); return TCL_OK; } @@ -1261,7 +1261,6 @@ TclCompileDictGetWithDefaultCmd( tokenPtr = TokenAfter(tokenPtr); } OP4( DICT_GET_DEF, numWords - 3); - TclAdjustStackDepth(-2, envPtr); return TCL_OK; } @@ -1297,7 +1296,6 @@ TclCompileDictExistsCmd( tokenPtr = TokenAfter(tokenPtr); } OP4( DICT_EXISTS, numWords - 2); - TclAdjustStackDepth(-1, envPtr); return TCL_OK; } @@ -1437,7 +1435,6 @@ TclCompileDictCreateCmd( CompileWord(envPtr, tokenPtr, interp, i+1); tokenPtr = TokenAfter(tokenPtr); OP44( DICT_SET, 1, worker); - TclAdjustStackDepth(-1, envPtr); OP( POP); } OP4( LOAD_SCALAR, worker); @@ -1520,7 +1517,6 @@ TclCompileDictMergeCmd( BACKLABEL( haveNext); OP4( REVERSE, 2); OP44( DICT_SET, 1, workerIndex); - TclAdjustStackDepth(-1, envPtr); OP( POP); OP4( DICT_NEXT, infoIndex); BACKJUMP( JUMP_FALSE, haveNext); @@ -1545,7 +1541,7 @@ TclCompileDictMergeCmd( * subsequent) dicts. This is strictly not necessary, but it is nice. */ - TclAdjustStackDepth(-1, envPtr); + STKDELTA(-1); ExceptionRangeTarget(envPtr, outLoop, catchOffset); OP( PUSH_RETURN_OPTIONS); OP( PUSH_RESULT); @@ -1731,7 +1727,6 @@ CompileDictEachCmd( OP4( LOAD_SCALAR, keyVarIndex); OP4( OVER, 1); OP44( DICT_SET, 1, collectVar); - TclAdjustStackDepth(-1, envPtr); OP( POP); } OP( POP); @@ -1759,7 +1754,7 @@ CompileDictEachCmd( * and re-throws the error. */ - TclAdjustStackDepth(-1, envPtr); + STKDELTA(-1); ExceptionRangeTarget(envPtr, catchRange, catchOffset); OP( PUSH_RETURN_OPTIONS); OP( PUSH_RESULT); @@ -2264,7 +2259,7 @@ TclCompileDictWithCmd( * Now fold the results back into the dictionary in the exception case. */ - TclAdjustStackDepth(-1, envPtr); + STKDELTA(-1); ExceptionRangeTarget(envPtr, range, catchOffset); OP( PUSH_RETURN_OPTIONS); OP( PUSH_RESULT); @@ -2876,7 +2871,7 @@ CompileEachloopCmd( ExceptionRangeTarget(envPtr, range, breakOffset); TclFinalizeLoopExceptionRange(envPtr, range); OP( FOREACH_END); - TclAdjustStackDepth(-(numLists+2), envPtr); + STKDELTA(-(numLists+2)); /* * Set the jumpback distance from INST_FOREACH_STEP to the start of the diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 0a74227..1492483 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -325,7 +325,7 @@ TclCompileIfCmd( * Fix the target of the jumpFalse after the test. */ - TclAdjustStackDepth(-1, envPtr); + STKDELTA(-1); TclFixupForwardJumpToHere(envPtr, jumpFalseFixupArray.fixup + jumpIndex); } else if (boolVal) { @@ -2356,7 +2356,7 @@ TclCompileReturnCmd( Tcl_DecrRefCount(returnOpts); OP( DONE); - TclAdjustStackDepth(1, envPtr); + STKDELTA(+1); return TCL_OK; } } diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 74385fd..452e38e 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -668,7 +668,7 @@ TclCompileStringIsCmd( FWDJUMP( JUMP_TRUE, satisfied); PUSH( "0"); FWDJUMP( JUMP, end); - TclAdjustStackDepth(-1, envPtr); + STKDELTA(-1); FWDLABEL( satisfied); } PUSH( "1"); @@ -690,7 +690,7 @@ TclCompileStringIsCmd( PUSH( ""); OP( STR_EQ); FWDJUMP( JUMP, end); - TclAdjustStackDepth(1, envPtr); + STKDELTA(+1); FWDLABEL( testNumType); OP4( REVERSE, 2); OP( POP); @@ -1604,7 +1604,7 @@ TclSubstCompile( /* Substitution produced TCL_OK */ OP( END_CATCH); FWDJUMP( JUMP, haveOk); - TclAdjustStackDepth(-1, envPtr); + STKDELTA(-1); /* Exceptional return codes processed here */ ExceptionRangeTarget(envPtr, catchRange, catchOffset); @@ -1633,7 +1633,7 @@ TclSubstCompile( /* OTHER */ FWDJUMP( JUMP, haveOther); - TclAdjustStackDepth(1, envPtr); + STKDELTA(+1); /* BREAK destination */ FWDLABEL( haveBreak); OP( POP); @@ -1641,14 +1641,14 @@ TclSubstCompile( BACKJUMP( JUMP, breakOffset); - TclAdjustStackDepth(2, envPtr); + STKDELTA(+2); /* CONTINUE destination */ FWDLABEL( haveContinue); OP( POP); OP( POP); FWDJUMP( JUMP, end); - TclAdjustStackDepth(2, envPtr); + STKDELTA(+2); /* RETURN + other destination */ FWDLABEL( haveReturn); FWDLABEL( haveOther); @@ -1685,7 +1685,7 @@ 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 */ @@ -2059,31 +2059,30 @@ IssueSwitchChainedTests( 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 + int *fwdJumps; /* Array of forward-jump fixup locations. */ + int jumpCount; /* Number of places to fix up. */ + int 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 + int contJumpCount; /* Number of continuation bodies pointing to * the current (or next) real body. */ int nextArmFixupIndex; int simple, exact; /* For extracting the type of regexp. */ int i; +#define NO_PENDING_JUMP -1 + /* * 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 = (int *)TclStackAlloc(interp, sizeof(int) * numBodyTokens); + jumpCount = 0; foundDefault = 0; for (i=0 ; isize != 7 || memcmp(bodyToken[numBodyTokens-2]->start, "default", 7)) { /* @@ -2129,8 +2128,7 @@ IssueSwitchChainedTests( if (TclReToGlob(NULL, bodyToken[i]->start, bodyToken[i]->size, &ds, &exact, NULL) == TCL_OK){ simple = 1; - PushLiteral(envPtr, Tcl_DStringValue(&ds), - Tcl_DStringLength(&ds)); + TclPushDString(envPtr, &ds); Tcl_DStringFree(&ds); } } @@ -2168,21 +2166,19 @@ IssueSwitchChainedTests( */ if (bodyToken[i+1]->size==1 && bodyToken[i+1]->start[0]=='-') { - if (contFixIndex == -1) { - contFixIndex = fixupCount; - contFixCount = 0; + 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; + jumpCount++; } else { /* * Got a default clause; set a flag to inhibit the generation of @@ -2204,13 +2200,14 @@ IssueSwitchChainedTests( * so we must process those first. */ - if (contFixIndex != -1) { + if (contJumpIdx != NO_PENDING_JUMP) { int j; - for (j=0 ; j=0 ; i--) { - TclFixupForwardJump(envPtr, &fixupArray[i], - fixupTargetArray[i] - fixupArray[i].codeOffset); - } - TclStackFree(interp, fixupTargetArray); - TclStackFree(interp, fixupArray); + TclStackFree(interp, fwdJumps); } /* @@ -2419,7 +2403,7 @@ IssueSwitchJumpTable( */ FWDJUMP( JUMP, finalFixups[numRealBodies++]); - TclAdjustStackDepth(-1, envPtr); + STKDELTA(-1); } } @@ -2597,7 +2581,7 @@ TclCompileTailcallCmd( tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, i); } - OP4( TAILCALL, (int)parsePtr->numWords); + OP4( TAILCALL, (int)parsePtr->numWords); return TCL_OK; } @@ -2693,7 +2677,8 @@ TclCompileThrowCmd( FWDJUMP( JUMP_FALSE, popForError); OP4( LIST, 2); OP44( RETURN_IMM, TCL_ERROR, 0); - TclAdjustStackDepth(2, envPtr); + + STKDELTA(+2); FWDLABEL( popForError); OP( POP); OP( POP); @@ -3012,12 +2997,12 @@ IssueTryClausesInstructions( if (!trapZero) { OP( END_CATCH); FWDJUMP( JUMP, afterBody); - TclAdjustStackDepth(-1, envPtr); + STKDELTA(-1); } else { PUSH( "0"); OP4( REVERSE, 2); FWDJUMP( JUMP, pushReturnOptions); - TclAdjustStackDepth(-2, envPtr); + STKDELTA(-2); } ExceptionRangeTarget(envPtr, range, catchOffset); OP( PUSH_RETURN_CODE); @@ -3061,7 +3046,6 @@ IssueTryClausesInstructions( OP4( LOAD_SCALAR, 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); @@ -3091,7 +3075,7 @@ IssueTryClausesInstructions( if (!handlerTokens[i]) { forwardsNeedFixing = 1; FWDJUMP( JUMP, forwardsToFix[i]); - TclAdjustStackDepth(1, envPtr); + STKDELTA(+1); } else { int dontChangeOptions; @@ -3113,8 +3097,9 @@ IssueTryClausesInstructions( } OP( END_CATCH); FWDJUMP( JUMP, noError[i]); + ExceptionRangeTarget(envPtr, range, catchOffset); - TclAdjustStackDepth(-1, envPtr); + STKDELTA(-1); OP( PUSH_RESULT); OP( PUSH_RETURN_OPTIONS); OP( PUSH_RETURN_CODE); @@ -3122,6 +3107,7 @@ IssueTryClausesInstructions( PUSH( "1"); OP( EQ); FWDJUMP( JUMP_FALSE, dontChangeOptions); + OP4( LOAD_SCALAR, optionsVar); OP4( REVERSE, 2); OP4( STORE_SCALAR, optionsVar); @@ -3129,7 +3115,7 @@ IssueTryClausesInstructions( PUSH( "-during"); OP4( REVERSE, 2); OP44( DICT_SET, 1, optionsVar); - TclAdjustStackDepth(-1, envPtr); + FWDLABEL( dontChangeOptions); OP4( REVERSE, 2); INVOKE( RETURN_STK); @@ -3237,7 +3223,7 @@ IssueTryClausesFinallyInstructions( PUSH( "0"); OP4( REVERSE, 2); FWDJUMP( JUMP, pushReturnOptions); - TclAdjustStackDepth(-2, envPtr); + STKDELTA(-2); } ExceptionRangeTarget(envPtr, range, catchOffset); OP( PUSH_RETURN_CODE); @@ -3280,7 +3266,6 @@ IssueTryClausesFinallyInstructions( OP4( LOAD_SCALAR, 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); @@ -3363,7 +3348,7 @@ IssueTryClausesFinallyInstructions( OP( PUSH_RETURN_OPTIONS); OP4( REVERSE, 3); FWDJUMP( JUMP, endCatch); - TclAdjustStackDepth(-3, envPtr); + STKDELTA(-3); forwardsToFix[i] = -1; /* @@ -3387,16 +3372,18 @@ IssueTryClausesFinallyInstructions( PUSH( "1"); OP( EQ); FWDJUMP( JUMP_FALSE, noTrapError); + OP4( LOAD_SCALAR, optionsVar); PUSH( "-during"); OP4( REVERSE, 3); OP4( STORE_SCALAR, optionsVar); OP( POP); OP44( DICT_SET, 1, optionsVar); - TclAdjustStackDepth(-1, envPtr); FWDJUMP( JUMP, trapError); + FWDLABEL( noTrapError); OP4( STORE_SCALAR, optionsVar); + FWDLABEL( trapError); /* Skip POP at end; can clean up with subsequent POP */ if (i+1 < numHandlers) { @@ -3406,7 +3393,7 @@ IssueTryClausesFinallyInstructions( endOfThisArm: if (i+1 < numHandlers) { FWDJUMP( JUMP, addrsToFix[i]); - TclAdjustStackDepth(1, envPtr); + STKDELTA(+1); } if (matchClauses[i]) { FWDLABEL( notECJumpSource); @@ -3461,16 +3448,18 @@ IssueTryClausesFinallyInstructions( OP4( STORE_SCALAR, optionsVar); OP( POP); OP44( DICT_SET, 1, optionsVar); - TclAdjustStackDepth(-1, envPtr); OP( POP); FWDJUMP( JUMP, finalError); - TclAdjustStackDepth(1, envPtr); + + STKDELTA(+1); FWDLABEL( noFinalError); OP4( STORE_SCALAR, optionsVar); OP( POP); + FWDLABEL( finalError); OP4( STORE_SCALAR, resultVar); OP( POP); + FWDLABEL( finalOK); OP4( LOAD_SCALAR, optionsVar); OP4( LOAD_SCALAR, resultVar); @@ -3502,11 +3491,11 @@ IssueTryFinallyInstructions( BODY( bodyToken, 1); } FWDJUMP( JUMP, endCatch); - TclAdjustStackDepth(-1, envPtr); + STKDELTA(-1); ExceptionRangeTarget(envPtr, range, catchOffset); OP( PUSH_RESULT); - OP( PUSH_RETURN_OPTIONS); FWDLABEL( endCatch); + OP( PUSH_RETURN_OPTIONS); OP( END_CATCH); // Finally diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 1b611a1..52da7c7 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -1402,6 +1402,14 @@ TclUpdateStackReqs( *(envPtr)->codeNext++ = (unsigned char) (tcl_i ); \ TclUpdateAtCmdStart(op, envPtr); \ TclUpdateStackReqs(op, tcl_i, envPtr); \ + /* Apply stack depth corrections. */ \ + switch(op) { \ + case INST_DICT_GET: case INST_DICT_EXISTS: \ + TclAdjustStackDepth(-1, envPtr); break; \ + case INST_DICT_GET_DEF: \ + TclAdjustStackDepth(-2, envPtr); break; \ + default: /* Do nothing special*/ break; \ + } \ } while (0) #define TclEmitInstInt14(op, i, j, envPtr) \ @@ -1453,6 +1461,12 @@ TclUpdateStackReqs( *(envPtr)->codeNext++ = (unsigned char) (tcl_j ); \ TclUpdateAtCmdStart(op, envPtr); \ TclUpdateStackReqs(op, tcl_i, envPtr); \ + /* Apply stack depth corrections. */ \ + switch(op) { \ + case INST_DICT_SET: \ + TclAdjustStackDepth(-1, envPtr); break; \ + default: /* Do nothing special*/ break; \ + } \ } while (0) /* @@ -1675,6 +1689,8 @@ TclUpdateStackReqs( #define TclRegisterDStringLiteral(envPtr, 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 -- cgit v0.12 From 02e0539f3c3e1a41a1701e6f859880477065035d Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 29 Mar 2025 11:57:25 +0000 Subject: Must reset exception ranges on syntax error in assembled code --- generic/tclAssembly.c | 2 ++ tests/assemble.test | 2 +- 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 427e3a4..66e3941 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -906,6 +906,7 @@ TclCompileAssembleCmd( size_t numCommands = envPtr->numCommands; int offset = envPtr->codeNext - envPtr->codeStart; size_t depth = envPtr->currStackDepth; + size_t numExnRanges = envPtr->exceptArrayNext; /* * Make sure that the command has a single arg that is a simple word. */ @@ -932,6 +933,7 @@ TclCompileAssembleCmd( envPtr->numCommands = numCommands; envPtr->codeNext = envPtr->codeStart + offset; envPtr->currStackDepth = depth; + envPtr->exceptArrayNext = numExnRanges; TclCompileSyntaxError(interp, envPtr); } return TCL_OK; diff --git a/tests/assemble.test b/tests/assemble.test index aaeb8a2..238d47f 100644 --- a/tests/assemble.test +++ b/tests/assemble.test @@ -2900,7 +2900,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} { -- cgit v0.12 From 0f6cd492bff0a46810a9cf8d707cd22177b77e79 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 29 Mar 2025 15:04:21 +0000 Subject: Fix [while] compilation, remove a couple of useless tests (opcode changes) --- generic/tclCompCmdsSZ.c | 8 ++------ tests/assemble.test | 34 +++++----------------------------- 2 files changed, 7 insertions(+), 35 deletions(-) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 452e38e..58db547 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -3701,7 +3701,7 @@ TclCompileWhileCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *testTokenPtr, *bodyTokenPtr; - int jumpEvalCond, testCodeOffset, bodyCodeOffset, range, code, boolVal; + int jumpEvalCond, testCodeOffset = 0, bodyCodeOffset, range, code, boolVal; int loopMayEnd = 1; /* This is set to 0 if it is recognized as an * infinite loop. */ Tcl_Obj *boolObj; @@ -3776,7 +3776,6 @@ TclCompileWhileCmd( if (loopMayEnd) { FWDJUMP( JUMP, jumpEvalCond); - testCodeOffset = 0; /* Avoid compiler warning. */ } else { /* * Make sure that the first command in the body is preceded by an @@ -3792,10 +3791,6 @@ TclCompileWhileCmd( */ BACKLABEL( bodyCodeOffset); - if (!loopMayEnd) { - envPtr->exceptArrayPtr[range].continueOffset = testCodeOffset; - envPtr->exceptArrayPtr[range].codeOffset = bodyCodeOffset; - } CATCH_RANGE(range) { BODY( bodyTokenPtr, 2); } @@ -3808,6 +3803,7 @@ TclCompileWhileCmd( if (loopMayEnd) { FWDLABEL( jumpEvalCond); + BACKLABEL( testCodeOffset); SetLineInformation(1); TclCompileExprWords(interp, testTokenPtr, 1, envPtr); diff --git a/tests/assemble.test b/tests/assemble.test index 238d47f..cc33b8f 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 { -- cgit v0.12 From eab48b4a778be5b82d76e4620cf29e66481e70f4 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 29 Mar 2025 15:22:50 +0000 Subject: more consistency of error messages --- generic/tclAssembly.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 66e3941..7ae54b8 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -1569,7 +1569,7 @@ AssembleOneLine( case ASSEM_LVT_SINT1: if (parsePtr->numWords != 3) { - Tcl_WrongNumArgs(interp, 1, &instNameObj, "varname imm8"); + Tcl_WrongNumArgs(interp, 1, &instNameObj, "varName imm8"); goto cleanup; } localVar = FindLocalVar(assemEnvPtr, &tokenPtr); @@ -1584,7 +1584,7 @@ AssembleOneLine( 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); -- cgit v0.12 From 254025c6d682cfde6e1cada371c419af7c60087b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 30 Mar 2025 08:41:50 +0000 Subject: Fix some -Wconversion warnings --- generic/tclFileName.c | 4 ++-- unix/tclSelectNotfy.c | 11 +++++++---- unix/tclUnixChan.c | 22 +++++++++++----------- unix/tclUnixCompat.c | 26 +++++++++++++------------- unix/tclUnixFCmd.c | 22 +++++++++++----------- unix/tclUnixFile.c | 24 ++++++++++++------------ unix/tclUnixPipe.c | 17 +++++++++-------- unix/tclUnixSock.c | 14 +++++++------- win/tclWinDde.c | 4 ++-- win/tclWinReg.c | 4 ++-- win/tclWinTime.c | 6 +++--- 11 files changed, 79 insertions(+), 75 deletions(-) diff --git a/generic/tclFileName.c b/generic/tclFileName.c index c92951a..068a041 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -1966,8 +1966,8 @@ DoGlob( Tcl_GlobTypeData *types) /* List object containing list of acceptable * types. May be NULL. */ { - int baseLength, quoted; - int result = TCL_OK; + Tcl_Size baseLength; + int quoted, result = TCL_OK; char *name, *p, *openBrace, *closeBrace, *firstSpecialChar; Tcl_Obj *joinedPtr; diff --git a/unix/tclSelectNotfy.c b/unix/tclSelectNotfy.c index bede898..58b5c3f 100644 --- a/unix/tclSelectNotfy.c +++ b/unix/tclSelectNotfy.c @@ -768,15 +768,18 @@ TclpWaitForEvent( if (!tsdPtr->eventReady) { #ifdef __CYGWIN__ if (!PeekMessageW(&msg, NULL, 0, 0, 0)) { - unsigned int timeout; + long long timeout; if (timePtr) { timeout = timePtr->sec * 1000 + timePtr->usec / 1000; + if (timeout > UINT_MAX) { + timeout = UINT_MAX; + } } else { - timeout = 0xFFFFFFFF; + timeout = UINT_MAX; } pthread_mutex_unlock(¬ifierMutex); - MsgWaitForMultipleObjects(1, &tsdPtr->event, 0, timeout, 1279); + MsgWaitForMultipleObjects(1, &tsdPtr->event, 0, (unsigned int)timeout, 1279); pthread_mutex_lock(¬ifierMutex); } #else /* !__CYGWIN__ */ @@ -806,7 +809,7 @@ TclpWaitForEvent( unsigned int result = GetMessageW(&msg, NULL, 0, 0); if (result == 0) { - PostQuitMessage(msg.wParam); + PostQuitMessage((int)msg.wParam); /* What to do here? */ } else if (result != (unsigned int) -1) { TranslateMessage(&msg); diff --git a/unix/tclUnixChan.c b/unix/tclUnixChan.c index 75584fe..4b184f5 100644 --- a/unix/tclUnixChan.c +++ b/unix/tclUnixChan.c @@ -266,7 +266,7 @@ FileInputProc( int *errorCodePtr) /* Where to store error code. */ { FileState *fsPtr = (FileState *)instanceData; - int bytesRead; /* How many bytes were actually read from the + ssize_t bytesRead; /* How many bytes were actually read from the * input device? */ *errorCodePtr = 0; @@ -286,7 +286,7 @@ FileInputProc( *errorCodePtr = errno; return -1; } - return bytesRead; + return (int)bytesRead; } /* @@ -315,7 +315,7 @@ FileOutputProc( int *errorCodePtr) /* Where to store error code. */ { FileState *fsPtr = (FileState *)instanceData; - int written; + ssize_t written; *errorCodePtr = 0; @@ -330,7 +330,7 @@ FileOutputProc( } written = write(fsPtr->fd, buf, toWrite); if (written >= 0) { - return written; + return (int)written; } *errorCodePtr = errno; return -1; @@ -659,7 +659,7 @@ FileGetOptionProc( { FileState *fsPtr = (FileState *)instanceData; int valid = 0; /* Flag if valid option parsed. */ - int len; + size_t len; if (optionName == NULL) { len = 0; @@ -860,18 +860,18 @@ TtySetOptionProc( iostate.c_cc[VSTOP] = 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]) { goto badXchar; } - iostate.c_cc[VSTART] = character; + iostate.c_cc[VSTART] = (cc_t)character; charLen = TclUtfToUniChar(argv[1], &character); if ((character > 0xFF) || argv[1][charLen]) { goto badXchar; } - iostate.c_cc[VSTOP] = character; + iostate.c_cc[VSTOP] = (cc_t)character; } Tcl_Free(argv); @@ -891,7 +891,7 @@ TtySetOptionProc( return TCL_ERROR; } iostate.c_cc[VMIN] = 0; - iostate.c_cc[VTIME] = (msec==0) ? 0 : (msec<100) ? 1 : (msec+50)/100; + iostate.c_cc[VTIME] = (msec==0) ? 0 : (msec<100) ? 1 : (cc_t)((msec+50)/100); tcsetattr(fsPtr->fileState.fd, TCSADRAIN, &iostate); return TCL_OK; } @@ -1906,7 +1906,7 @@ Tcl_MakeFileChannel( { TtyState *fsPtr; char channelName[16 + TCL_INTEGER_SPACE]; - int fd = PTR2INT(handle); + int fd = (int)PTR2INT(handle); const Tcl_ChannelType *channelTypePtr; Tcl_StatBuf buf; @@ -2112,7 +2112,7 @@ Tcl_GetOpenFile( || (strcmp(chanTypePtr->typeName, "pipe") == 0)) { if (Tcl_GetChannelHandle(chan, (forWriting ? TCL_WRITABLE : TCL_READABLE), &data) == TCL_OK) { - fd = PTR2INT(data); + fd = (int)PTR2INT(data); /* * The call to fdopen below is probably dangerous, since it will diff --git a/unix/tclUnixCompat.c b/unix/tclUnixCompat.c index def69fa..7120b86 100644 --- a/unix/tclUnixCompat.c +++ b/unix/tclUnixCompat.c @@ -107,11 +107,11 @@ static int CopyGrp(struct group *tgtPtr, char *buf, int buflen); static int CopyPwd(struct passwd *tgtPtr, char *buf, int buflen); #endif -static int CopyArray(char **src, int elsize, char *buf, - int buflen); +static size_t CopyArray(char **src, int elsize, char *buf, + size_t buflen); static int CopyHostent(struct hostent *tgtPtr, char *buf, - int buflen); -static int CopyString(const char *src, char *buf, int buflen); + size_t buflen); +static size_t CopyString(const char *src, char *buf, size_t buflen); #endif @@ -754,10 +754,10 @@ static int CopyHostent( struct hostent *tgtPtr, char *buf, - int buflen) + size_t buflen) { char *p = buf; - int copied, len = 0; + Tcl_Size copied, len = 0; copied = CopyString(tgtPtr->h_name, p, buflen - len); if (copied == -1) { @@ -875,16 +875,16 @@ CopyPwd( */ #ifdef NEED_COPYARRAY -static int +static size_t CopyArray( char **src, /* Array of elements to copy. */ int elsize, /* Size of each element, or -1 to indicate * that they are C strings of dynamic * length. */ char *buf, /* Buffer to copy into. */ - int buflen) /* Size of buffer. */ + size_t buflen) /* Size of buffer. */ { - int i, j, len = 0; + size_t i, j, len = 0; char *p, **newBuffer; if (src == NULL) { @@ -905,7 +905,7 @@ CopyArray( p = buf + len; for (j = 0; j < i; j++) { - int sz = (elsize<0 ? (int) strlen(src[j]) + 1 : elsize); + size_t sz = (elsize<0 ? strlen(src[j]) + 1 : (size_t)elsize); len += sz; if (len > buflen) { @@ -939,13 +939,13 @@ CopyArray( */ #ifdef NEED_COPYSTRING -static int +static size_t CopyString( const char *src, /* String to copy. */ char *buf, /* Buffer to copy into. */ - int buflen) /* Size of buffer. */ + size_t buflen) /* Size of buffer. */ { - int len = 0; + size_t len = 0; if (src != NULL) { len = strlen(src) + 1; diff --git a/unix/tclUnixFCmd.c b/unix/tclUnixFCmd.c index db45999..9bc9da6 100644 --- a/unix/tclUnixFCmd.c +++ b/unix/tclUnixFCmd.c @@ -452,11 +452,11 @@ DoCopyFile( } } - switch ((int) (statBufPtr->st_mode & S_IFMT)) { + switch ((int)(statBufPtr->st_mode & S_IFMT)) { #ifndef DJGPP case S_IFLNK: { char linkBuf[MAXPATHLEN+1]; - int length; + ssize_t length; length = readlink(src, linkBuf, MAXPATHLEN); /* INTL: Native. */ if (length == -1) { @@ -1069,7 +1069,7 @@ TraverseUnixTree( while ((ent = fts_read(fts)) != NULL) { unsigned short info = ent->fts_info; char *path = ent->fts_path + sourceLen; - unsigned short pathlen = ent->fts_pathlen - sourceLen; + Tcl_Size pathlen = ent->fts_pathlen - sourceLen; int type; Tcl_StatBuf *statBufPtr = NULL; @@ -1626,7 +1626,7 @@ SetPermissionsAttribute( int result = TCL_ERROR; const char *native; const char *modeStringPtr = TclGetString(attributePtr); - int scanned = TclParseAllWhiteSpace(modeStringPtr, -1); + Tcl_Size scanned = TclParseAllWhiteSpace(modeStringPtr, -1); /* * First supply support for octal number format @@ -1978,7 +1978,7 @@ TclpObjNormalizePath( * routine should be reviewed and cleaed up. */ } else { - nextCheckpoint = lastDir - path; + nextCheckpoint = (int)(lastDir - path); goto wholeStringOk; } } @@ -2021,7 +2021,7 @@ TclpObjNormalizePath( * Assign the end of the current component to nextCheckpoint */ - nextCheckpoint = currentPathEndPosition - path; + nextCheckpoint = (int)(currentPathEndPosition - path); } else if (cur == 0) { /* * The end of the string. @@ -2096,7 +2096,7 @@ TclpObjNormalizePath( * Append the remaining path components. */ - int normLen = Tcl_DStringLength(&ds); + Tcl_Size normLen = Tcl_DStringLength(&ds); Tcl_DStringAppend(&ds, path + nextCheckpoint, pathLen - nextCheckpoint); @@ -2106,13 +2106,13 @@ TclpObjNormalizePath( * been processed */ - nextCheckpoint = normLen + 1; + nextCheckpoint = (int)normLen + 1; } else { /* * We recognise the whole string. */ - nextCheckpoint = Tcl_DStringLength(&ds); + nextCheckpoint = (int)Tcl_DStringLength(&ds); } Tcl_SetStringObj(pathPtr, Tcl_DStringValue(&ds), @@ -2214,7 +2214,7 @@ TclUnixOpenTemporaryFile( return -1; } TclDStringAppendDString(&templ, &tmp); - fd = mkstemps(Tcl_DStringValue(&templ), Tcl_DStringLength(&tmp)); + fd = mkstemps(Tcl_DStringValue(&templ), (int)Tcl_DStringLength(&tmp)); Tcl_DStringFree(&tmp); } else #endif @@ -2387,7 +2387,7 @@ static WCHAR * winPathFromObj( Tcl_Obj *fileName) { - size_t size; + int size; const char *native = (const char *)Tcl_FSGetNativePath(fileName); WCHAR *winPath; diff --git a/unix/tclUnixFile.c b/unix/tclUnixFile.c index 2b0b5b0..97acb24 100644 --- a/unix/tclUnixFile.c +++ b/unix/tclUnixFile.c @@ -1237,13 +1237,13 @@ TclOSfstat( Tcl_StatBuf *statBuf = (Tcl_StatBuf *)cygstat; int result = fstat(fd, &buf); - statBuf->st_mode = buf.st_mode; - statBuf->st_ino = buf.st_ino; + statBuf->st_mode = (unsigned short)buf.st_mode; + statBuf->st_ino = (unsigned short)buf.st_ino; statBuf->st_dev = buf.st_dev; statBuf->st_rdev = buf.st_rdev; statBuf->st_nlink = buf.st_nlink; - statBuf->st_uid = buf.st_uid; - statBuf->st_gid = buf.st_gid; + statBuf->st_uid = (short)buf.st_uid; + statBuf->st_gid = (short)buf.st_gid; statBuf->st_size = buf.st_size; statBuf->st_atime = buf.st_atime; statBuf->st_mtime = buf.st_mtime; @@ -1260,13 +1260,13 @@ TclOSstat( Tcl_StatBuf *statBuf = (Tcl_StatBuf *)cygstat; int result = stat(name, &buf); - statBuf->st_mode = buf.st_mode; - statBuf->st_ino = buf.st_ino; + statBuf->st_mode = (unsigned short)buf.st_mode; + statBuf->st_ino = (unsigned short)buf.st_ino; statBuf->st_dev = buf.st_dev; statBuf->st_rdev = buf.st_rdev; statBuf->st_nlink = buf.st_nlink; - statBuf->st_uid = buf.st_uid; - statBuf->st_gid = buf.st_gid; + statBuf->st_uid = (short)buf.st_uid; + statBuf->st_gid = (short)buf.st_gid; statBuf->st_size = buf.st_size; statBuf->st_atime = buf.st_atime; statBuf->st_mtime = buf.st_mtime; @@ -1283,13 +1283,13 @@ TclOSlstat( Tcl_StatBuf *statBuf = (Tcl_StatBuf *)cygstat; int result = lstat(name, &buf); - statBuf->st_mode = buf.st_mode; - statBuf->st_ino = buf.st_ino; + statBuf->st_mode = (unsigned short)buf.st_mode; + statBuf->st_ino = (unsigned short)buf.st_ino; statBuf->st_dev = buf.st_dev; statBuf->st_rdev = buf.st_rdev; statBuf->st_nlink = buf.st_nlink; - statBuf->st_uid = buf.st_uid; - statBuf->st_gid = buf.st_gid; + statBuf->st_uid = (short)buf.st_uid; + statBuf->st_gid = (short)buf.st_gid; statBuf->st_size = buf.st_size; statBuf->st_atime = buf.st_atime; statBuf->st_mtime = buf.st_mtime; diff --git a/unix/tclUnixPipe.c b/unix/tclUnixPipe.c index 8d4a6b0..ca452d7 100644 --- a/unix/tclUnixPipe.c +++ b/unix/tclUnixPipe.c @@ -34,8 +34,8 @@ * the same as NULL. */ -#define MakeFile(fd) ((TclFile) INT2PTR(((int) (fd)) + 1)) -#define GetFd(file) (PTR2INT(file) - 1) +#define MakeFile(fd) ((TclFile)INT2PTR((fd) + 1)) +#define GetFd(file) ((int)PTR2INT(file) - 1) /* * This structure describes per-instance state of a pipe based channel. @@ -426,7 +426,8 @@ TclpCreateProcess( * process. */ { TclFile errPipeIn, errPipeOut; - int count, status, fd; + ssize_t count; + int status, fd; char errSpace[200 + TCL_INTEGER_SPACE]; Tcl_DString *volatile dsArray; char **volatile newArgv; @@ -630,7 +631,7 @@ TclpCreateProcess( char *end; errSpace[count] = 0; - errno = strtol(errSpace, &end, 10); + errno = (int)strtol(errSpace, &end, 10); Tcl_SetObjResult(interp, Tcl_ObjPrintf("%s: %s", end, Tcl_PosixError(interp))); goto error; @@ -1147,7 +1148,7 @@ PipeInputProc( int *errorCodePtr) /* Where to store error code. */ { PipeState *psPtr = (PipeState *)instanceData; - int bytesRead; /* How many bytes were actually read from the + ssize_t bytesRead; /* How many bytes were actually read from the * input device? */ *errorCodePtr = 0; @@ -1168,7 +1169,7 @@ PipeInputProc( *errorCodePtr = errno; return -1; } - return bytesRead; + return (int)bytesRead; } /* @@ -1197,7 +1198,7 @@ PipeOutputProc( int *errorCodePtr) /* Where to store error code. */ { PipeState *psPtr = (PipeState *)instanceData; - int written; + ssize_t written; *errorCodePtr = 0; @@ -1214,7 +1215,7 @@ PipeOutputProc( *errorCodePtr = errno; return -1; } - return written; + return (int)written; } /* diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c index f2b15b2..cfdf98d 100644 --- a/unix/tclUnixSock.c +++ b/unix/tclUnixSock.c @@ -508,7 +508,7 @@ TcpInputProc( int *errorCodePtr) /* Where to store error code. */ { TcpState *statePtr = (TcpState *)instanceData; - int bytesRead; + ssize_t bytesRead; *errorCodePtr = 0; if (WaitForConnect(statePtr, errorCodePtr) != 0) { @@ -516,7 +516,7 @@ TcpInputProc( } bytesRead = recv(statePtr->fds.fd, buf, bufSize, 0); if (bytesRead >= 0) { - return bytesRead; + return (int)bytesRead; } if (errno == ECONNRESET) { /* @@ -558,7 +558,7 @@ TcpOutputProc( int *errorCodePtr) /* Where to store error code. */ { TcpState *statePtr = (TcpState *)instanceData; - int written; + ssize_t written; *errorCodePtr = 0; if (WaitForConnect(statePtr, errorCodePtr) != 0) { @@ -567,7 +567,7 @@ TcpOutputProc( written = send(statePtr->fds.fd, buf, toWrite, 0); if (written >= 0) { - return written; + return (int)written; } *errorCodePtr = errno; return -1; @@ -1607,7 +1607,7 @@ TclpMakeTcpClientChannelMode( statePtr = (TcpState *)Tcl_Alloc(sizeof(TcpState)); memset(statePtr, 0, sizeof(TcpState)); - statePtr->fds.fd = PTR2INT(sock); + statePtr->fds.fd = (int)PTR2INT(sock); statePtr->flags = 0; snprintf(channelName, sizeof(channelName), SOCK_TEMPLATE, PTR2INT(statePtr)); @@ -1768,8 +1768,8 @@ Tcl_OpenTcpServerEx( */ if (port == 0 && chosenport != 0) { - ((struct sockaddr_in *) addrPtr->ai_addr)->sin_port = - htons(chosenport); + ((struct sockaddr_in *)addrPtr->ai_addr)->sin_port = + htons((uint16_t)chosenport); } #ifdef IPV6_V6ONLY diff --git a/win/tclWinDde.c b/win/tclWinDde.c index 12a10e6..17643e3 100644 --- a/win/tclWinDde.c +++ b/win/tclWinDde.c @@ -1334,8 +1334,8 @@ DdeObjCmd( }; int index, argIndex; - Tcl_Size length, i; - int flags = 0, result = TCL_OK, firstArg = 0; + Tcl_Size length, i, firstArg = 0; + int flags = 0, result = TCL_OK; HSZ ddeService = NULL, ddeTopic = NULL, ddeItem = NULL, ddeCookie = NULL; HDDEDATA ddeData = NULL, ddeItemData = NULL, ddeReturn; HCONV hConv = NULL; diff --git a/win/tclWinReg.c b/win/tclWinReg.c index 59de335..7b6302c 100644 --- a/win/tclWinReg.c +++ b/win/tclWinReg.c @@ -808,7 +808,7 @@ GetValue( * HKEY_PERFORMANCE_DATA */ - length = Tcl_DStringLength(&data) * (2 / sizeof(WCHAR)); + length = (DWORD)(Tcl_DStringLength(&data) * (2 / sizeof(WCHAR))); Tcl_DStringSetLength(&data, length * sizeof(WCHAR)); result = RegQueryValueExW(key, nativeValue, NULL, &type, (BYTE *) Tcl_DStringValue(&data), &length); @@ -1501,7 +1501,7 @@ AppendSystemError( Tcl_Interp *interp, /* Current interpreter. */ DWORD error) /* Result code from error. */ { - int length; + Tcl_Size length; WCHAR *tMsgPtr, **tMsgPtrPtr = &tMsgPtr; const char *msg; char id[TCL_INTEGER_SPACE], msgBuf[24 + TCL_INTEGER_SPACE]; diff --git a/win/tclWinTime.c b/win/tclWinTime.c index 8cc4489..c0d2b2e 100644 --- a/win/tclWinTime.c +++ b/win/tclWinTime.c @@ -260,7 +260,7 @@ TclpGetWideClicks(void) if (QueryPerformanceFrequency(&perfCounterFreq)) { wideClick.perfCounter = 1; - wideClick.microsecsScale = 1000000.0 / perfCounterFreq.QuadPart; + wideClick.microsecsScale = 1000000.0 / (double)perfCounterFreq.QuadPart; } else { /* fallback using microseconds */ wideClick.perfCounter = 0; @@ -384,7 +384,7 @@ Tcl_GetTime( if (IsTimeNative() && (usecSincePosixEpoch = NativeGetMicroseconds())) { timePtr->sec = usecSincePosixEpoch / 1000000; - timePtr->usec = usecSincePosixEpoch % 1000000; + timePtr->usec = (long)(usecSincePosixEpoch % 1000000); } else { GetTime(timePtr); } @@ -687,7 +687,7 @@ NativeGetTime( usecSincePosixEpoch = NativeGetMicroseconds(); if (usecSincePosixEpoch) { timePtr->sec = usecSincePosixEpoch / 1000000; - timePtr->usec = usecSincePosixEpoch % 1000000; + timePtr->usec = (long)(usecSincePosixEpoch % 1000000); } else { /* * High resolution timer is not available. Just use ftime. -- cgit v0.12 From c6322dc7d50d221c62755b26bae41ae0191638d2 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 30 Mar 2025 16:30:26 +0000 Subject: Reset after failure a bit more carefully. --- generic/tclAssembly.c | 19 +++++++++---------- 1 file changed, 9 insertions(+), 10 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 7ae54b8..82a6336 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -736,8 +736,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"); @@ -755,12 +753,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; } @@ -902,11 +897,13 @@ TclCompileAssembleCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *tokenPtr; /* Token in the input script */ - size_t numCommands = envPtr->numCommands; - int offset = envPtr->codeNext - envPtr->codeStart; + Tcl_Size offset = envPtr->codeNext - envPtr->codeStart; size_t depth = envPtr->currStackDepth; size_t numExnRanges = envPtr->exceptArrayNext; + size_t numAuxRanges = envPtr->auxDataArrayNext; + size_t exceptDepth = envPtr->exceptDepth; + /* * Make sure that the command has a single arg that is a simple word. */ @@ -934,6 +931,8 @@ TclCompileAssembleCmd( envPtr->codeNext = envPtr->codeStart + offset; envPtr->currStackDepth = depth; envPtr->exceptArrayNext = numExnRanges; + envPtr->auxDataArrayNext = numAuxRanges; + envPtr->exceptDepth = exceptDepth; TclCompileSyntaxError(interp, envPtr); } return TCL_OK; -- cgit v0.12 From afdadec486258114538b321625923ebd8d7f1699 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 30 Mar 2025 16:45:57 +0000 Subject: Forgot a critical file. Derp! --- generic/tclCompUtils.h | 61 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 61 insertions(+) create mode 100644 generic/tclCompUtils.h diff --git a/generic/tclCompUtils.h b/generic/tclCompUtils.h new file mode 100644 index 0000000..08cc349 --- /dev/null +++ b/generic/tclCompUtils.h @@ -0,0 +1,61 @@ +/* + * tclCompUtils.h -- + * + * This file contains utility macros for generating Tcl bytecode. + * + * Copyright (c) 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. + */ + +#ifndef _TCLCOMPUTILS +#define _TCLCOMPUTILS 1 + +#include "tclCompile.h" + +/* + * 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) \ + TclEmitInstInt14(INST_##name,(val1),(val2),envPtr) +#define OP44(name,val1,val2) \ + TclEmitInstInt44(INST_##name,(val1),(val2),envPtr) +#define OP41(name,val1,val2) \ + TclEmitInstInt41(INST_##name,(val1),(val2),envPtr) + +#define PUSH(str) \ + PushStringLiteral(envPtr, str) +#define BACKLABEL(var) \ + (var)=CurrentOffset(envPtr) +#define BACKJUMP(name, var) \ + TclEmitInstInt4(INST_##name,(var)-CurrentOffset(envPtr),envPtr) +#define FWDJUMP(name,var) \ + (var)=CurrentOffset(envPtr);TclEmitInstInt4(INST_##name,0,envPtr) +#define FWDLABEL(var) \ + TclStoreInt4AtPtr(CurrentOffset(envPtr)-(var),envPtr->codeStart+(var)+1) +#define INVOKE(name) \ + TclEmitInvoke(envPtr,INST_##name) + +#define CATCH_RANGE(range) \ + for(int tcl__range=(ExceptionRangeStarts(envPtr,(range)),0); \ + !tcl__range; \ + tcl__range=(ExceptionRangeEnds(envPtr,(range)),1)) + +#define STKDELTA(delta) \ + TclAdjustStackDepth((delta), envPtr) + +#endif + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ -- cgit v0.12 From 0706496a4613d6f96e359546930831c54979639d Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 30 Mar 2025 17:11:03 +0000 Subject: More corrections --- generic/tclDisassemble.c | 1 + unix/Makefile.in | 7 ++++--- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index d252e35..a95dcb1 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 diff --git a/unix/Makefile.in b/unix/Makefile.in index 8377612..0a38601 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -1253,6 +1253,7 @@ REGHDRS = $(GENERIC_DIR)/regex.h $(GENERIC_DIR)/regguts.h \ $(GENERIC_DIR)/regcustom.h TCLREHDRS = $(GENERIC_DIR)/tclRegexp.h COMPILEHDR = $(GENERIC_DIR)/tclCompile.h +COMPUTILHDR = $(GENERIC_DIR)/tclCompUtils.h FSHDR = $(GENERIC_DIR)/tclFileSystem.h IOHDR = $(GENERIC_DIR)/tclIO.h MATHHDRS = $(GENERIC_DIR)/tclTomMath.h $(GENERIC_DIR)/tclTomMathDecls.h @@ -1320,13 +1321,13 @@ tclCmdMZ.o: $(GENERIC_DIR)/tclCmdMZ.c $(TCLREHDRS) $(TRIMHDR) tclDate.o: $(GENERIC_DIR)/tclDate.c $(TCLDATEHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclDate.c -tclCompCmds.o: $(GENERIC_DIR)/tclCompCmds.c $(COMPILEHDR) +tclCompCmds.o: $(GENERIC_DIR)/tclCompCmds.c $(COMPILEHDR) $(COMPUTILHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCompCmds.c -tclCompCmdsGR.o: $(GENERIC_DIR)/tclCompCmdsGR.c $(COMPILEHDR) +tclCompCmdsGR.o: $(GENERIC_DIR)/tclCompCmdsGR.c $(COMPILEHDR) $(COMPUTILHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCompCmdsGR.c -tclCompCmdsSZ.o: $(GENERIC_DIR)/tclCompCmdsSZ.c $(COMPILEHDR) $(TRIMHDR) +tclCompCmdsSZ.o: $(GENERIC_DIR)/tclCompCmdsSZ.c $(COMPILEHDR) $(COMPUTILHDR) $(TRIMHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCompCmdsSZ.c tclCompExpr.o: $(GENERIC_DIR)/tclCompExpr.c $(COMPILEHDR) -- cgit v0.12 From 916d53022c1cb80653dd784240787473f0cf2822 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 2 Apr 2025 08:52:24 +0000 Subject: Another round of -Wconversion fixes --- doc/Limit.3 | 2 +- generic/tcl.decls | 2 +- generic/tclArithSeries.c | 12 ++++++------ generic/tclBasic.c | 20 ++++++++++---------- generic/tclBinary.c | 12 ++++++------ generic/tclCompCmdsGR.c | 2 +- generic/tclCompile.h | 2 +- generic/tclDecls.h | 4 ++-- generic/tclEnsemble.c | 7 ++++--- generic/tclExecute.c | 4 ++-- generic/tclHash.c | 4 ++-- generic/tclIndexObj.c | 16 ++++++++-------- generic/tclInt.h | 2 +- generic/tclInterp.c | 4 ++-- generic/tclLiteral.c | 10 +++++----- generic/tclOOInt.h | 2 +- generic/tclObj.c | 4 ++-- generic/tclPkg.c | 20 ++++++++++---------- generic/tclTimer.c | 2 +- generic/tclTrace.c | 2 +- generic/tclUtf.c | 8 ++++---- 21 files changed, 71 insertions(+), 70 deletions(-) diff --git a/doc/Limit.3 b/doc/Limit.3 index 5eb3ac8..a4005f3 100644 --- a/doc/Limit.3 +++ b/doc/Limit.3 @@ -32,7 +32,7 @@ int .sp \fBTcl_LimitTypeReset\fR(\fIinterp, type\fR) .sp -int +Tcl_Size \fBTcl_LimitGetCommands\fR(\fIinterp\fR) .sp \fBTcl_LimitSetCommands\fR(\fIinterp, commandLimit\fR) diff --git a/generic/tcl.decls b/generic/tcl.decls index cd337cc..bf18d2c 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -1689,7 +1689,7 @@ declare 531 { void Tcl_LimitTypeReset(Tcl_Interp *interp, int type) } declare 532 { - int Tcl_LimitGetCommands(Tcl_Interp *interp) + Tcl_Size Tcl_LimitGetCommands(Tcl_Interp *interp) } declare 533 { void Tcl_LimitGetTime(Tcl_Interp *interp, Tcl_Time *timeLimitPtr) diff --git a/generic/tclArithSeries.c b/generic/tclArithSeries.c index a63a53a..2192e7e 100755 --- a/generic/tclArithSeries.c +++ b/generic/tclArithSeries.c @@ -168,7 +168,7 @@ ArithSeriesEndDbl( if (!dblRepPtr->base.len) { return dblRepPtr->start; } - d = dblRepPtr->start + ((dblRepPtr->base.len-1) * dblRepPtr->step); + d = dblRepPtr->start + ((double)(dblRepPtr->base.len-1) * dblRepPtr->step); return ArithRound(d, dblRepPtr->precision); } @@ -191,7 +191,7 @@ ArithSeriesIndexDbl( assert(arithSeriesRepPtr->isDouble); double d = dblRepPtr->start; if (index) { - d += (index * dblRepPtr->step); + d += ((double)index * dblRepPtr->step); } return ArithRound(d, dblRepPtr->precision); @@ -234,7 +234,7 @@ ObjPrecision( if (strchr(str, 'e') == NULL && strchr(str, 'E') == NULL) { str = strchr(str, '.'); - return (str ? strlen(str + 1) : 0); + return (str ? (unsigned)strlen(str + 1) : 0); } /* don't calculate precision for e-notation */ } @@ -712,13 +712,13 @@ TclNewArithSeriesObj( // Compute precision based on given command argument values precision = maxObjPrecision(startObj, NULL, stepObj); - dend = dstart + (dstep * (len-1)); + dend = dstart + (dstep * (double)(len-1)); // Make computed end value match argument(s) precision dend = ArithRound(dend, precision); end = dend; } else { end = start + (step * (len - 1)); - dend = end; + dend = (double)end; } } @@ -738,7 +738,7 @@ TclNewArithSeriesObj( if (useDoubles) { /* ensure we'll not get NaN somewhere in the arith-series, * so simply check the end of it and behave like [expr {Inf - Inf}] */ - double d = dstart + (len - 1) * dstep; + 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)); diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 73eb602..3cbf091 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; @@ -4437,7 +4437,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; @@ -5179,7 +5179,7 @@ TclEvalEx( const char *p, *next; const int minObjs = 20; Tcl_Obj **objv, **objvSpace; - int *expand; + char *expand; Tcl_Size *lines, *lineSpace; Tcl_Token *tokenPtr; int expandRequested, code = TCL_OK; @@ -5196,7 +5196,7 @@ 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)); + char *expandStack = (char *)TclStackAlloc(interp, minObjs * sizeof(char)); Tcl_Size *linesStack = (Tcl_Size *)TclStackAlloc(interp, minObjs * sizeof(Tcl_Size)); /* TIP #280 Structures for tracking of command * locations. */ @@ -5333,7 +5333,7 @@ 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 *) @@ -6293,7 +6293,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) { @@ -7770,7 +7770,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. @@ -8260,8 +8260,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]); diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 675f250..6edebc5 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -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; @@ -2665,7 +2665,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; @@ -2972,14 +2972,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/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 45befc7..cab74a5 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -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; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 3e2626c..f0d26dd 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -1310,7 +1310,7 @@ TclUpdateStackReqs( } \ *(envPtr)->codeNext++ = (unsigned char) (op); \ TclUpdateAtCmdStart(op, envPtr); \ - TclUpdateStackReqs(op, 0, envPtr); \ + TclUpdateStackReqs((unsigned char)op, 0, envPtr); \ } while (0) /* diff --git a/generic/tclDecls.h b/generic/tclDecls.h index c8f2eaf..1a72149 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1401,7 +1401,7 @@ EXTERN void Tcl_LimitTypeSet(Tcl_Interp *interp, int type); /* 531 */ EXTERN void Tcl_LimitTypeReset(Tcl_Interp *interp, int type); /* 532 */ -EXTERN int Tcl_LimitGetCommands(Tcl_Interp *interp); +EXTERN Tcl_Size Tcl_LimitGetCommands(Tcl_Interp *interp); /* 533 */ EXTERN void Tcl_LimitGetTime(Tcl_Interp *interp, Tcl_Time *timeLimitPtr); @@ -2413,7 +2413,7 @@ typedef struct TclStubs { int (*tcl_LimitTypeExceeded) (Tcl_Interp *interp, int type); /* 529 */ void (*tcl_LimitTypeSet) (Tcl_Interp *interp, int type); /* 530 */ void (*tcl_LimitTypeReset) (Tcl_Interp *interp, int type); /* 531 */ - int (*tcl_LimitGetCommands) (Tcl_Interp *interp); /* 532 */ + Tcl_Size (*tcl_LimitGetCommands) (Tcl_Interp *interp); /* 532 */ void (*tcl_LimitGetTime) (Tcl_Interp *interp, Tcl_Time *timeLimitPtr); /* 533 */ int (*tcl_LimitGetGranularity) (Tcl_Interp *interp, int type); /* 534 */ Tcl_InterpState (*tcl_SaveInterpState) (Tcl_Interp *interp, int status); /* 535 */ diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index a11f382..c3e26e2 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, @@ -585,7 +585,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; @@ -1578,7 +1578,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. diff --git a/generic/tclExecute.c b/generic/tclExecute.c index fced7d0..0cee5fa 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -943,8 +943,8 @@ wordSkip( void *ptr) { int mask = TCL_ALLOCALIGN-1; - int base = PTR2INT(ptr) & mask; - return (TCL_ALLOCALIGN - base)/sizeof(Tcl_Obj *); + int base = (int)PTR2INT(ptr) & mask; + return (TCL_ALLOCALIGN - base)/(int)sizeof(Tcl_Obj *); } /* diff --git a/generic/tclHash.c b/generic/tclHash.c index e093107..8b33455 100644 --- a/generic/tclHash.c +++ b/generic/tclHash.c @@ -621,9 +621,9 @@ Tcl_HashStats( } else { overflow++; } - tmp = j; + tmp = (double)j; if (tablePtr->numEntries != 0) { - average += (tmp+1.0)*(tmp/tablePtr->numEntries)/2.0; + average += (tmp+1.0)*(tmp/(double)tablePtr->numEntries)/2.0; } } diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index f41a537..91bec09 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -303,20 +303,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; @@ -1107,7 +1107,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) { @@ -1139,7 +1139,7 @@ Tcl_ParseArgsObjv( */ if (infoPtr->dstPtr != NULL) { - *((int *) infoPtr->dstPtr) = dstIndex; + *((int *)infoPtr->dstPtr) = (int)dstIndex; } goto argsDone; case TCL_ARGV_FLOAT: @@ -1147,7 +1147,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]))); @@ -1268,7 +1268,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.h b/generic/tclInt.h index 004c2a9..c124219 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2435,7 +2435,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 /* diff --git a/generic/tclInterp.c b/generic/tclInterp.c index 8ccaa65..8276145 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -3962,7 +3962,7 @@ Tcl_LimitSetCommands( *---------------------------------------------------------------------- */ -int +Tcl_Size Tcl_LimitGetCommands( Tcl_Interp *interp) { @@ -4329,7 +4329,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/tclLiteral.c b/generic/tclLiteral.c index 38508ec..4506086 100644 --- a/generic/tclLiteral.c +++ b/generic/tclLiteral.c @@ -29,7 +29,7 @@ */ 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, Tcl_Size length); #ifdef TCL_COMPILE_DEBUG @@ -439,7 +439,7 @@ TclRegisterLiteral( if (objIndex > INT_MAX) { Tcl_Panic("Literal table index too large. Cannot be handled by TclEmitPush"); } - return objIndex; + return (int)objIndex; } } @@ -481,7 +481,7 @@ TclRegisterLiteral( Tcl_Panic( "Literal table index too large. Cannot be handled by TclEmitPush"); } - return objIndex; + return (int)objIndex; } #ifdef TCL_COMPILE_DEBUG @@ -646,7 +646,7 @@ TclAddLiteralObj( *litPtrPtr = lPtr; } - return objIndex; + return (int)objIndex; } /* @@ -672,7 +672,7 @@ AddLocalLiteralEntry( 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; diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index 28de527..febf708 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. */ }; /* diff --git a/generic/tclObj.c b/generic/tclObj.c index fdefcb3..8c58c00 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -2052,13 +2052,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; } diff --git a/generic/tclPkg.c b/generic/tclPkg.c index fc48631..8473010 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -86,12 +86,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[]); @@ -583,7 +583,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 +649,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; @@ -1955,10 +1955,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)) { @@ -2061,7 +2061,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. */ @@ -2141,12 +2141,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/tclTimer.c b/generic/tclTimer.c index bd0664e..2c566f6 100644 --- a/generic/tclTimer.c +++ b/generic/tclTimer.c @@ -1115,7 +1115,7 @@ GetAfterEvent( return NULL; } cmdString += 6; - id = strtoul(cmdString, &end, 10); + id = (int)strtoul(cmdString, &end, 10); if ((end == cmdString) || (*end != 0)) { return NULL; } diff --git a/generic/tclTrace.c b/generic/tclTrace.c index 4d7e7d5..f1d83e7 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -1787,7 +1787,7 @@ 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); diff --git a/generic/tclUtf.c b/generic/tclUtf.c index 36ff919..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 */ @@ -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); } -- cgit v0.12 From 86b29e49cad048bc52671c840f468d18c5644a2e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 2 Apr 2025 22:16:13 +0000 Subject: Fix "load" testcases on Cygwin, due to wrong --out-implib --- unix/configure | 2 +- unix/tcl.m4 | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/unix/configure b/unix/configure index c22b465..0da6449 100755 --- a/unix/configure +++ b/unix/configure @@ -5950,7 +5950,7 @@ fi ;; CYGWIN_*|MINGW32_*|MSYS_*) SHLIB_CFLAGS="-fno-common" - SHLIB_LD='${CC} -shared -Wl,--out-implib,$(patsubst cyg%.dll,lib%.dll.a,$@)' + SHLIB_LD='${CC} -shared -Wl,--out-implib,$(patsubst cyg%.dll,lib%.dll,$@).a' SHLIB_SUFFIX=".dll" DL_OBJS="tclLoadDl.o" PLAT_OBJS='${CYGWIN_OBJS}' diff --git a/unix/tcl.m4 b/unix/tcl.m4 index 92d0b27..ce01ee8 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -1079,7 +1079,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ ;; CYGWIN_*|MINGW32_*|MSYS_*) SHLIB_CFLAGS="-fno-common" - SHLIB_LD='${CC} -shared -Wl,--out-implib,$(patsubst cyg%.dll,lib%.dll.a,$[@])' + SHLIB_LD='${CC} -shared -Wl,--out-implib,$(patsubst cyg%.dll,lib%.dll,$[@]).a' SHLIB_SUFFIX=".dll" DL_OBJS="tclLoadDl.o" PLAT_OBJS='${CYGWIN_OBJS}' -- cgit v0.12 From 2240efba0359b827157b537cad7121c41ffb7598 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 6 Apr 2025 15:55:57 +0000 Subject: Eliminate some -Wconversion warnings. Fix comments --- generic/tclIcu.c | 67 ++++++++++++++++++++++++++++---------------------------- 1 file changed, 33 insertions(+), 34 deletions(-) diff --git a/generic/tclIcu.c b/generic/tclIcu.c index 1dd901b..57edc15 100644 --- a/generic/tclIcu.c +++ b/generic/tclIcu.c @@ -349,7 +349,7 @@ DetectEncoding( return FunctionNotAvailableError(interp); } - bytes = (char *) Tcl_GetBytesFromObj(interp, objPtr, &len); + bytes = (char *)Tcl_GetBytesFromObj(interp, objPtr, &len); if (bytes == NULL) { return TCL_ERROR; } @@ -360,7 +360,7 @@ DetectEncoding( return IcuError(interp, "Could not open charset detector", status); } - ucsdet_setText(csd, bytes, len, &status); + ucsdet_setText(csd, bytes, (int)len, &status); if (U_FAILURE(status)) { IcuError(interp, "Could not set detection text", status); ucsdet_close(csd); @@ -569,11 +569,11 @@ IcuObjFromUCharDString( /* *------------------------------------------------------------------------ * - * EncodingDetectObjCmd -- + * IcuDetectObjCmd -- * - * Implements the Tcl command EncodingDetect. - * encdetect - returns names of all detectable encodings - * encdetect BYTES ?-all? - return detected encoding(s) + * Implements the Tcl command ::tcl::unsupported::icu::detect. + * ::tcl::unsupported::icu::detect - returns names of all detectable encodings + * ::tcl::unsupported::icu::detect BYTES ?-all? - return detected encoding(s) * * Results: * TCL_OK - Success. @@ -743,10 +743,10 @@ IcuConverterAliasesObjCmd( static int IcuConverttoDString( Tcl_Interp *interp, - Tcl_DString *dsInPtr, /* Input UTF16 */ + Tcl_DString *dsInPtr, /* Input UTF16 */ const char *icuEncName, int strict, - Tcl_DString *dsOutPtr) /* Output encoded string. */ + Tcl_DString *dsOutPtr) /* Output encoded string. */ { if (ucnv_open == NULL || ucnv_close == NULL || ucnv_fromUChars == NULL || UCNV_FROM_U_CALLBACK_STOP == NULL) { @@ -779,17 +779,17 @@ IcuConverttoDString( dstCapacity = utf16len; Tcl_DStringInit(dsOutPtr); Tcl_DStringSetLength(dsOutPtr, dstCapacity); - dstLen = ucnv_fromUChars(ucnvPtr, Tcl_DStringValue(dsOutPtr), dstCapacity, - utf16, utf16len, &status); + dstLen = ucnv_fromUChars(ucnvPtr, Tcl_DStringValue(dsOutPtr), (int)dstCapacity, + utf16, (int)utf16len, &status); if (U_FAILURE(status)) { switch (status) { case U_STRING_NOT_TERMINATED_WARNING: break; /* We don't care */ case U_BUFFER_OVERFLOW_ERROR: - Tcl_DStringSetLength(dsOutPtr, dstLen); + Tcl_DStringSetLength(dsOutPtr, (int)dstLen); status = U_ZERO_ERRORZ; /* Reset before call */ - dstLen = ucnv_fromUChars(ucnvPtr, Tcl_DStringValue(dsOutPtr), dstLen, - utf16, utf16len, &status); + dstLen = ucnv_fromUChars(ucnvPtr, Tcl_DStringValue(dsOutPtr), (int)dstLen, + utf16, (int)utf16len, &status); if (U_SUCCESS(status)) { break; } @@ -827,7 +827,7 @@ IcuBytesToUCharDString( Tcl_Size nbytes, const char *icuEncName, int strict, - Tcl_DString *dsOutPtr) /* Output UChar string. */ + Tcl_DString *dsOutPtr) /* Output UChar string. */ { if (ucnv_open == NULL || ucnv_close == NULL || ucnv_toUChars == NULL || UCNV_TO_U_CALLBACK_STOP == NULL) { @@ -855,11 +855,11 @@ IcuBytesToUCharDString( } int dstLen; - int dstCapacity = (int) nbytes; /* In UChar's */ + int dstCapacity = (int)nbytes; /* In UChar's */ Tcl_DStringInit(dsOutPtr); Tcl_DStringSetLength(dsOutPtr, dstCapacity); dstLen = ucnv_toUChars(ucnvPtr, (UCharx *)Tcl_DStringValue(dsOutPtr), dstCapacity, - (const char *)bytes, nbytes, &status); + (const char *)bytes, (int)nbytes, &status); if (U_FAILURE(status)) { switch (status) { case U_STRING_NOT_TERMINATED_WARNING: @@ -869,7 +869,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, nbytes, &status); + (const char *)bytes, (int)nbytes, &status); if (U_SUCCESS(status)) { break; } @@ -905,9 +905,9 @@ IcuBytesToUCharDString( static int IcuNormalizeUCharDString( Tcl_Interp *interp, - Tcl_DString *dsInPtr, /* Input UTF16 */ + Tcl_DString *dsInPtr, /* Input UTF16 */ NormalizationMode mode, - Tcl_DString *dsOutPtr) /* Output normalized UTF16. */ + Tcl_DString *dsOutPtr) /* Output normalized UTF16. */ { typedef UNormalizer2 *(*normFn)(UErrorCodex *); normFn fn = NULL; @@ -953,7 +953,7 @@ IcuNormalizeUCharDString( normPtr = (UCharx *) Tcl_DStringValue(dsOutPtr); normLen = unorm2_normalize( - normalizer, utf16, utf16len, normPtr, utf16len, &status); + normalizer, utf16, (int)utf16len, normPtr, (int)utf16len, &status); if (U_FAILURE(status)) { switch (status) { case U_STRING_NOT_TERMINATED_WARNING: @@ -965,7 +965,7 @@ IcuNormalizeUCharDString( normPtr = (UCharx *) Tcl_DStringValue(dsOutPtr); status = U_ZERO_ERRORZ; /* Need to clear error! */ normLen = unorm2_normalize( - normalizer, utf16, utf16len, normPtr, normLen, &status); + normalizer, utf16, (int)utf16len, normPtr, normLen, &status); if (U_SUCCESS(status)) { break; } @@ -1060,9 +1060,9 @@ static int IcuParseConvertOptions( static int IcuConvertfromObjCmd( 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. */ { int strict; Tcl_Obj *failindexVar; @@ -1111,9 +1111,9 @@ IcuConvertfromObjCmd( static int IcuConverttoObjCmd( 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. */ { int strict; Tcl_Obj *failindexVar; @@ -1156,9 +1156,9 @@ IcuConverttoObjCmd( static int IcuNormalizeObjCmd( 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 *optNames[] = {"-profile", "-mode", NULL}; enum { OPT_PROFILE, OPT_MODE } opt; @@ -1271,10 +1271,9 @@ TclIcuCleanup( */ static void * IcuFindSymbol( - Tcl_LoadHandle loadH, /* Handle to shared library containing symbol */ - const char *name, /* Name of function */ - const char *suffix /* Suffix that may be present */ -) + Tcl_LoadHandle loadH, /* Handle to shared library containing symbol */ + const char *name, /* Name of function */ + const char *suffix) /* Suffix that may be present */ { /* * ICU symbols may have a version suffix depending on how it was built. -- cgit v0.12 From 8f7ab1f2845d2af28f651508f6e155e54b3620c1 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 6 Apr 2025 16:12:26 +0000 Subject: Fix [02fe7f5c89]: tcl::unsupported::icu::detect missing 32-bit error-check --- generic/tclIcu.c | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/generic/tclIcu.c b/generic/tclIcu.c index 57edc15..3110281 100644 --- a/generic/tclIcu.c +++ b/generic/tclIcu.c @@ -353,6 +353,11 @@ DetectEncoding( if (bytes == NULL) { return TCL_ERROR; } + if (len > INT_MAX) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("Max length supported by ICU exceeded.", TCL_INDEX_NONE)); + return TCL_ERROR; + } UErrorCodex status = U_ZERO_ERRORZ; UCharsetDetector* csd = ucsdet_open(&status); @@ -771,7 +776,7 @@ IcuConverttoDString( Tcl_Size utf16len = Tcl_DStringLength(dsInPtr) / sizeof(UCharx); Tcl_Size dstLen, dstCapacity; if (utf16len > INT_MAX) { - Tcl_SetObjResult( interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj("Max length supported by ICU exceeded.", TCL_INDEX_NONE)); return TCL_ERROR; } @@ -1020,8 +1025,7 @@ static int IcuParseConvertOptions( if (!strcmp(s, "replace")) { strict = 0; } else if (strcmp(s, "strict")) { - Tcl_SetObjResult( - interp, + Tcl_SetObjResult(interp, Tcl_ObjPrintf("Invalid value \"%s\" supplied for option" " \"-profile\". Must be \"strict\" or \"replace\".", s)); @@ -1189,8 +1193,7 @@ IcuNormalizeObjCmd( if (!strcmp(s, "replace")) { strict = 0; } else if (strcmp(s, "strict")) { - Tcl_SetObjResult( - interp, + Tcl_SetObjResult(interp, Tcl_ObjPrintf("Invalid value \"%s\" supplied for option \"-profile\". Must be " "\"strict\" or \"replace\".", s)); -- cgit v0.12 From bf2ec5f3b45c0755dfbd7ed141f66087e7484438 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 7 Apr 2025 09:41:52 +0000 Subject: (cherry-pick): Fix [010d8f3885] tclEpollNotfy PlatformEventsControl panics if websocket disconnected --- unix/tclEpollNotfy.c | 20 +++++++++++++------- 1 file changed, 13 insertions(+), 7 deletions(-) diff --git a/unix/tclEpollNotfy.c b/unix/tclEpollNotfy.c index 8c392f0..0138a00 100644 --- a/unix/tclEpollNotfy.c +++ b/unix/tclEpollNotfy.c @@ -42,7 +42,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- @@ -223,10 +223,16 @@ PlatformEventsControl( */ if (TclOSfstat(filePtr->fd, &fdStat) == -1) { - Tcl_Panic("fstat: %s", strerror(errno)); - } - - if (epoll_ctl(tsdPtr->eventsFd, op, filePtr->fd, &newEvent) == -1) { + /* + * The tclEpollNotfy PlatformEventsControl function panics if the TclOSfstat + * call returns -1, which occurs when using a websocket to a browser and the + * browser page is refreshed. It seems the fstat call isn't doing anything + * useful, in particular the contents of the statbuf aren't examined afterwards + * on success and at best it changes the panic message. Instead we avoid the + * panic at the cost of a memory leak. + */ + return; + } else if (epoll_ctl(tsdPtr->eventsFd, op, filePtr->fd, &newEvent) == -1) { switch (errno) { case EPERM: switch (op) { @@ -513,7 +519,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); @@ -791,7 +797,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. */ { -- cgit v0.12 From be7b10605c92bfc7be4f6399348e9d9d962b6211 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 7 Apr 2025 14:48:58 +0000 Subject: Remove OPTS=tk8 option: It was meant to be able to compile extesions witk Tk 8.7, which will never fly .... --- win/rules.vc | 9 +-------- 1 file changed, 1 insertion(+), 8 deletions(-) diff --git a/win/rules.vc b/win/rules.vc index a78e482..b1bb93b 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -881,10 +881,6 @@ USE_THREAD_ALLOC= 0 !message *** Build for Tcl8 TCL_BUILD_FOR = 8 !endif -!if [nmakehlp -f $(OPTS) "tk8"] -!message *** Build for Tk8 -TK_BUILD_FOR = 8 -!endif !if $(TCL_MAJOR_VERSION) == 8 !if [nmakehlp -f $(OPTS) "time64bit"] @@ -1454,10 +1450,7 @@ OPTDEFINES = $(OPTDEFINES) /D_USE_64BIT_TIME_T=1 !endif !endif !if "$(TCL_BUILD_FOR)" == "8" -OPTDEFINES = $(OPTDEFINES) /DTCL_MAJOR_VERSION=8 -!endif -!if "$(TK_BUILD_FOR)" == "8" -OPTDEFINES = $(OPTDEFINES) /DTK_MAJOR_VERSION=8 +OPTDEFINES = $(OPTDEFINES) /DTCL_MAJOR_VERSION=8 /DTK_MAJOR_VERSION=8 !endif # Like the TEA system only set this non empty for non-Tk extensions -- cgit v0.12 From 1ebc8b52e0a441cb65e5f56fca0bbdd65b53e413 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 9 Apr 2025 13:49:54 +0000 Subject: Update rules.vc --- win/rules.vc | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/win/rules.vc b/win/rules.vc index b1bb93b..414e85c 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -1641,7 +1641,7 @@ default-target: $(DEFAULT_BUILD_TARGET) !if $(MULTIPLATFORM_INSTALL) default-pkgindex: - @echo if {[package vsatisfies [package provide Tcl] 9.0-]} { > $(OUT_DIR)\pkgIndex.tcl + @echo if {[package vsatisfies [package provide Tcl] 9.0]} { > $(OUT_DIR)\pkgIndex.tcl @echo package ifneeded $(PRJ_PACKAGE_TCLNAME) $(DOTVERSION) \ [list load [file join $$dir $(PLATFORM_IDENTIFY) $(PRJLIBNAME9)]] >> $(OUT_DIR)\pkgIndex.tcl @echo } else { >> $(OUT_DIR)\pkgIndex.tcl @@ -1650,7 +1650,7 @@ default-pkgindex: @echo } >> $(OUT_DIR)\pkgIndex.tcl !else default-pkgindex: - @echo if {[package vsatisfies [package provide Tcl] 9.0-]} { > $(OUT_DIR)\pkgIndex.tcl + @echo if {[package vsatisfies [package provide Tcl] 9.0]} { > $(OUT_DIR)\pkgIndex.tcl @echo package ifneeded $(PRJ_PACKAGE_TCLNAME) $(DOTVERSION) \ [list load [file join $$dir $(PRJLIBNAME9)]] >> $(OUT_DIR)\pkgIndex.tcl @echo } else { >> $(OUT_DIR)\pkgIndex.tcl -- cgit v0.12 From be8b424ef4bd8e1879205715ff0ea28be3b6873b Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 9 Apr 2025 14:18:06 +0000 Subject: Cleaning up a bunch of things in code generation. --- generic/tclAssembly.c | 61 ++-- generic/tclCompCmds.c | 671 +++++++++++++++++++---------------- generic/tclCompCmdsGR.c | 195 ++++++----- generic/tclCompCmdsSZ.c | 891 +++++++++++++++++++++++------------------------ generic/tclCompExpr.c | 5 +- generic/tclCompUtils.h | 56 ++- generic/tclCompile.c | 690 ++++++++++++++++++++++++------------ generic/tclCompile.h | 606 ++++++++++++++++++++------------ generic/tclDisassemble.c | 2 +- generic/tclEnsemble.c | 28 +- generic/tclExecute.c | 218 ++++++++---- generic/tclLiteral.c | 2 +- generic/tclProc.c | 4 +- win/tcltest.rc | 75 ---- 14 files changed, 1992 insertions(+), 1512 deletions(-) delete mode 100644 win/tcltest.rc diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 82a6336..f658fa7 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -471,6 +471,7 @@ 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}, {"tclooIsObject", ASSEM_1BYTE, INST_TCLOO_IS_OBJECT, 1, 1}, {"tclooNamespace", ASSEM_1BYTE, INST_TCLOO_NS, 1, 1}, @@ -501,24 +502,23 @@ static const TalInstDesc TalInstructionTable[] = { static const unsigned char NonThrowingByteCodes[] = { INST_PUSH1, INST_PUSH, INST_POP, INST_DUP, /* 1-4 */ INST_JUMP1, INST_JUMP, /* 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_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 */ }; /* @@ -665,7 +665,7 @@ BBEmitOpcode( * number. */ - if (bbPtr->startOffset == envPtr->codeNext - envPtr->codeStart) { + if (bbPtr->startOffset == CurrentOffset(envPtr)) { bbPtr->startLine = assemEnvPtr->cmdLine; } @@ -898,7 +898,7 @@ TclCompileAssembleCmd( { Tcl_Token *tokenPtr; /* Token in the input script */ size_t numCommands = envPtr->numCommands; - Tcl_Size offset = envPtr->codeNext - envPtr->codeStart; + Tcl_Size offset = CurrentOffset(envPtr); size_t depth = envPtr->currStackDepth; size_t numExnRanges = envPtr->exceptArrayNext; size_t numAuxRanges = envPtr->auxDataArrayNext; @@ -1027,9 +1027,10 @@ TclAssembleCode( */ #ifdef TCL_COMPILE_DEBUG - if ((tclTraceCompile >= 2) && (envPtr->procPtr == NULL)) { + if ((tclTraceCompile >= TCL_TRACE_BYTECODE_COMPILE_DETAIL) + && (envPtr->procPtr == NULL)) { printf(" %4" TCL_Z_MODIFIER "d Assembling: ", - envPtr->codeNext - envPtr->codeStart); + CurrentOffset(envPtr)); TclPrintSource(stdout, parsePtr->commandStart, TclMin(instLen, 55)); printf("\n"); @@ -1280,7 +1281,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); @@ -1451,7 +1452,7 @@ AssembleOneLine( if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) { goto cleanup; } - assemEnvPtr->curr_bb->jumpOffset = envPtr->codeNext-envPtr->codeStart; + assemEnvPtr->curr_bb->jumpOffset = CurrentOffset(envPtr); flags = 0; BBEmitInstInt4(assemEnvPtr, tblIdx, 0, 0); @@ -1479,10 +1480,10 @@ AssembleOneLine( Tcl_InitHashTable(&jtPtr->hashTable, TCL_STRING_KEYS); assemEnvPtr->curr_bb->jumpLine = assemEnvPtr->cmdLine; - assemEnvPtr->curr_bb->jumpOffset = envPtr->codeNext-envPtr->codeStart; + assemEnvPtr->curr_bb->jumpOffset = CurrentOffset(envPtr); DEBUG_PRINT("bb %p jumpLine %d jumpOffset %d\n", assemEnvPtr->curr_bb, assemEnvPtr->cmdLine, - envPtr->codeNext - envPtr->codeStart); + CurrentOffset(envPtr)); infoIndex = TclCreateAuxData(jtPtr, &tclJumptableInfoType, envPtr); DEBUG_PRINT("auxdata index=%d\n", infoIndex); @@ -2501,7 +2502,7 @@ StartBasicBlock( * Coalesce zero-length blocks. */ - if (currBB->startOffset == envPtr->codeNext - envPtr->codeStart) { + if (currBB->startOffset == CurrentOffset(envPtr)) { currBB->startLine = assemEnvPtr->cmdLine; return currBB; } @@ -2558,7 +2559,7 @@ AllocBB( 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; @@ -2899,7 +2900,7 @@ MoveCodeForJumps( * their new homes. */ - topOffset = envPtr->codeNext - envPtr->codeStart; + topOffset = CurrentOffset(envPtr); for (bbPtr = assemEnvPtr->curr_bb; bbPtr != NULL; bbPtr = bbPtr->prevPtr) { DEBUG_PRINT("move code from %d to %d\n", bbPtr->originalStartOffset, bbPtr->startOffset); @@ -3116,7 +3117,7 @@ CheckNonThrowingBlock( nextPtr = blockPtr->successor1; if (nextPtr == NULL) { - bound = envPtr->codeNext - envPtr->codeStart; + bound = CurrentOffset(envPtr); } else { bound = nextPtr->startOffset; } diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 841ebca..e309085 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -37,6 +37,11 @@ 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 CompileDictWithEmpty(Tcl_Interp *interp, int numWords, + Tcl_Token *varTokenPtr, CompileEnv *envPtr); +static inline void CompileDictWithBodied(Tcl_Interp *interp, int numWords, + Tcl_Token *varTokenPtr, CompileEnv *envPtr); + /* * The structures below define the AuxData types defined in this file. @@ -128,7 +133,8 @@ TclCompileAppendCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr, *valueTokenPtr; - int isScalar, localIndex, numWords, i; + int isScalar, numWords, i; + Tcl_LVTIndex localIndex; /* TODO: Consider support for compiling expanded args. */ numWords = parsePtr->numWords; @@ -169,7 +175,7 @@ TclCompileAppendCmd( */ valueTokenPtr = TokenAfter(varTokenPtr); - CompileWord(envPtr, valueTokenPtr, interp, 2); + PUSH_TOKEN( valueTokenPtr, 2); /* * Emit instructions to set/get the variable. @@ -211,7 +217,7 @@ TclCompileAppendCmd( valueTokenPtr = TokenAfter(varTokenPtr); for (i = 2 ; i < numWords ; i++) { - CompileWord(envPtr, valueTokenPtr, interp, i); + PUSH_TOKEN( valueTokenPtr, i); valueTokenPtr = TokenAfter(valueTokenPtr); } OP4( REVERSE, numWords - 2); @@ -253,7 +259,8 @@ TclCompileArrayExistsCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - int isScalar, localIndex; + int isScalar; + Tcl_LVTIndex localIndex; if (parsePtr->numWords != 2) { return TCL_ERROR; @@ -285,14 +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 offsetBack; + Tcl_LVTIndex keyVar, valVar, localIndex; + Tcl_AuxDataRef infoIndex; Tcl_Obj *literalObj; ForeachInfo *infoPtr; - int arrayMade; + Tcl_BytecodeLabel arrayMade, offsetBack; if (parsePtr->numWords != 3) { return TCL_ERROR; @@ -353,13 +359,13 @@ TclCompileArraySetCmd( if (isDataEven && len == 0) { if (localIndex >= 0) { - int haveArray; + Tcl_BytecodeLabel haveArray; OP4( ARRAY_EXISTS_IMM, localIndex); FWDJUMP( JUMP_TRUE, haveArray); OP4( ARRAY_MAKE_IMM, localIndex); FWDLABEL( haveArray); } else { - int haveArray; + Tcl_BytecodeLabel haveArray; OP( DUP); OP( ARRAY_EXISTS_STK); FWDJUMP( JUMP_TRUE, haveArray); @@ -385,7 +391,7 @@ TclCompileArraySetCmd( localIndex = TclFindCompiledLocal(varTokenPtr->start, varTokenPtr->size, 1, envPtr); PUSH( "0"); - OP4( REVERSE, 2); + OP( SWAP); OP4( UPVAR, localIndex); OP( POP); } @@ -416,7 +422,7 @@ TclCompileArraySetCmd( 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 @@ -425,7 +431,7 @@ TclCompileArraySetCmd( * use-case with [array set]). */ - int ok; + Tcl_BytecodeLabel ok; OP( DUP); OP( LIST_LENGTH); PUSH( "1"); @@ -439,7 +445,7 @@ TclCompileArraySetCmd( } OP4( FOREACH_START, infoIndex); - offsetBack = CurrentOffset(envPtr); + BACKLABEL( offsetBack); OP4( LOAD_SCALAR, keyVar); OP4( LOAD_SCALAR, valVar); OP4( STORE_ARRAY, localIndex); @@ -466,8 +472,9 @@ TclCompileArrayUnsetCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); - int isScalar, localIndex; - int noSuchArray, end; + int isScalar; + Tcl_LVTIndex localIndex; + Tcl_BytecodeLabel noSuchArray, end; if (parsePtr->numWords != 2) { return TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr); @@ -483,7 +490,6 @@ TclCompileArrayUnsetCmd( OP4( ARRAY_EXISTS_IMM, localIndex); FWDJUMP( JUMP_FALSE, end); OP14( UNSET_SCALAR, 1, localIndex); - FWDLABEL( end); } else { OP( DUP); OP( ARRAY_EXISTS_STK); @@ -495,8 +501,8 @@ TclCompileArrayUnsetCmd( STKDELTA(+1); FWDLABEL( noSuchArray); OP( POP); - FWDLABEL( end); } + FWDLABEL( end); PUSH( ""); return TCL_OK; } @@ -586,7 +592,10 @@ TclCompileCatchCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *cmdTokenPtr, *resultNameTokenPtr, *optsNameTokenPtr; - int resultIndex, optsIndex, range, dropScript = 0, haveResultAndCode; + int dropScript = 0; + Tcl_LVTIndex resultIndex, optsIndex; + Tcl_BytecodeLabel haveResultAndCode; + Tcl_ExceptionRange range; int depth = TclGetStackDepth(envPtr); /* @@ -648,15 +657,14 @@ 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) { OP4( BEGIN_CATCH, range); CATCH_RANGE(range) { BODY( cmdTokenPtr, 1); } } else { - SetLineInformation(1); - CompileTokens(envPtr, cmdTokenPtr, interp); + PUSH_TOKEN( cmdTokenPtr, 1); OP4( BEGIN_CATCH, range); OP( DUP); CATCH_RANGE(range) { @@ -664,7 +672,7 @@ TclCompileCatchCmd( } /* drop the script */ dropScript = 1; - OP4( REVERSE, 2); + OP( SWAP); OP( POP); } @@ -675,6 +683,7 @@ TclCompileCatchCmd( TclCheckStackDepth(depth+1, envPtr); PUSH( "0"); + OP( SWAP); FWDJUMP( JUMP, haveResultAndCode); /* @@ -682,7 +691,7 @@ TclCompileCatchCmd( * return code. */ - ExceptionRangeTarget(envPtr, range, catchOffset); + CATCH_TARGET( range); TclSetStackDepth(depth + dropScript, envPtr); if (dropScript) { @@ -690,10 +699,10 @@ TclCompileCatchCmd( } /* Stack at this point is empty */ - OP( PUSH_RESULT); 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 */ FWDLABEL( haveResultAndCode); @@ -721,14 +730,6 @@ TclCompileCatchCmd( 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. - */ - - OP4( REVERSE, 2); if (resultIndex != -1) { OP4( STORE_SCALAR, resultIndex); } @@ -884,8 +885,8 @@ TclCompileConcatCmd( tokenPtr = TokenAfter(tokenPtr); TclNewObj(objPtr); if (!TclWordKnownAtCompileTime(tokenPtr, objPtr)) { - Tcl_DecrRefCount(objPtr); - Tcl_DecrRefCount(listObj); + Tcl_BounceRefCount(objPtr); + Tcl_BounceRefCount(listObj); listObj = NULL; break; } @@ -893,15 +894,12 @@ TclCompileConcatCmd( } if (listObj != NULL) { Tcl_Obj **objs; - const char *bytes; - Tcl_Size len, slen; + Tcl_Size len; TclListObjGetElements(NULL, listObj, &len, &objs); objPtr = Tcl_ConcatObj(len, objs); - Tcl_DecrRefCount(listObj); - bytes = TclGetStringFromObj(objPtr, &slen); - PushLiteral(envPtr, bytes, slen); - Tcl_DecrRefCount(objPtr); + Tcl_BounceRefCount(listObj); + PUSH_OBJ( objPtr); return TCL_OK; } @@ -911,7 +909,7 @@ TclCompileConcatCmd( for (i = 1, tokenPtr = parsePtr->tokenPtr; i < (int)parsePtr->numWords; i++) { tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, i); + PUSH_TOKEN( tokenPtr, i); } OP4( CONCAT_STK, i - 1); @@ -946,7 +944,8 @@ TclCompileConstCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr, *valueTokenPtr; - int isScalar, localIndex; + int isScalar; + Tcl_LVTIndex localIndex; /* * Need exactly two arguments. @@ -981,7 +980,7 @@ TclCompileConstCmd( */ valueTokenPtr = TokenAfter(varTokenPtr); - CompileWord(envPtr, valueTokenPtr, interp, 2); + PUSH_TOKEN( valueTokenPtr, 2); if (localIndex < 0) { OP( CONST_STK); @@ -1086,7 +1085,8 @@ TclCompileDictSetCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - int i, dictVarIndex, numWords = (int) parsePtr->numWords; + int i, numWords = (int) parsePtr->numWords; + Tcl_LVTIndex dictVarIndex; Tcl_Token *varTokenPtr; /* @@ -1115,7 +1115,7 @@ TclCompileDictSetCmd( tokenPtr = TokenAfter(varTokenPtr); for (i=2 ; itokenPtr); for (i=1 ; inumWords; + int i, numWords = (int) parsePtr->numWords; + Tcl_LVTIndex dictVarIndex; /* * There must be at least one argument after the variable name for us to @@ -1340,7 +1342,7 @@ TclCompileDictUnsetCmd( for (i=2 ; inumWords & 1) == 0) { return TCL_ERROR; @@ -1376,41 +1376,36 @@ 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) { 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); + Tcl_BounceRefCount(valueObj); } /* * We did! Excellent. The "verifyDict" is to do type forcing. */ - bytes = TclGetStringFromObj(dictObj, &len); - PushLiteral(envPtr, bytes, len); + PUSH_OBJ( dictObj); OP( DUP); OP( DICT_VERIFY); - Tcl_DecrRefCount(dictObj); return TCL_OK; /* @@ -1420,6 +1415,9 @@ TclCompileDictCreateCmd( */ nonConstant: + if (!EnvHasLVT(envPtr)) { + return TclCompileBasicMin0ArgCmd(interp, parsePtr, cmdPtr, envPtr); + } worker = AnonymousLocal(envPtr); if (worker < 0) { return TclCompileBasicMin0ArgCmd(interp, parsePtr, cmdPtr, envPtr); @@ -1428,14 +1426,14 @@ TclCompileDictCreateCmd( PUSH( ""); OP4( STORE_SCALAR, worker); OP( POP); - tokenPtr = TokenAfter(parsePtr->tokenPtr); + keyToken = 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); + valueToken = TokenAfter(keyToken); + PUSH_TOKEN( keyToken, i); + PUSH_TOKEN( valueToken, i + 1); OP44( DICT_SET, 1, worker); OP( POP); + keyToken = TokenAfter(valueToken); } OP4( LOAD_SCALAR, worker); OP14( UNSET_SCALAR, 0, worker); @@ -1453,7 +1451,10 @@ TclCompileDictMergeCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - int i, workerIndex, infoIndex, outLoop, end; + int i; + Tcl_LVTIndex worker, infoIndex; + Tcl_ExceptionRange outLoop; + Tcl_BytecodeLabel end; /* * Deal with some special edge cases. Note that in the case with one @@ -1466,7 +1467,7 @@ TclCompileDictMergeCmd( return TCL_OK; } else if (parsePtr->numWords == 2) { tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); + PUSH_TOKEN( tokenPtr, 1); OP( DUP); OP( DICT_VERIFY); return TCL_OK; @@ -1479,8 +1480,11 @@ TclCompileDictMergeCmd( * command when there's an LVT present. */ - workerIndex = AnonymousLocal(envPtr); - if (workerIndex < 0) { + if (!EnvHasLVT(envPtr)) { + return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr); + } + worker = AnonymousLocal(envPtr); + if (worker < 0) { return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr); } infoIndex = AnonymousLocal(envPtr); @@ -1490,33 +1494,33 @@ TclCompileDictMergeCmd( */ tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); + PUSH_TOKEN( tokenPtr, 1); OP( DUP); OP( DICT_VERIFY); - OP4( STORE_SCALAR, workerIndex); + OP4( STORE_SCALAR, worker); OP( POP); /* * For each of the remaining dictionaries... */ - outLoop = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); + outLoop = MAKE_CATCH_RANGE(); OP4( BEGIN_CATCH, outLoop); CATCH_RANGE(outLoop) { for (i=2 ; i<(int)parsePtr->numWords ; i++) { - int haveNext, noNext; + Tcl_BytecodeLabel haveNext, noNext; /* * Get the dictionary, and merge its pairs into the first dict (using * a small loop). */ tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, i); + PUSH_TOKEN( tokenPtr, i); OP4( DICT_FIRST, infoIndex); FWDJUMP( JUMP_TRUE, noNext); BACKLABEL( haveNext); - OP4( REVERSE, 2); - OP44( DICT_SET, 1, workerIndex); + OP( SWAP); + OP44( DICT_SET, 1, worker); OP( POP); OP4( DICT_NEXT, infoIndex); BACKJUMP( JUMP_FALSE, haveNext); @@ -1532,21 +1536,21 @@ TclCompileDictMergeCmd( * Clean up any state left over. */ - OP4( LOAD_SCALAR, workerIndex); - OP14( UNSET_SCALAR, 0, workerIndex); + OP4( LOAD_SCALAR, worker); + OP14( UNSET_SCALAR, 0, worker); 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. */ - STKDELTA(-1); - ExceptionRangeTarget(envPtr, outLoop, catchOffset); + CATCH_TARGET(outLoop); OP( PUSH_RETURN_OPTIONS); OP( PUSH_RESULT); OP( END_CATCH); - OP14( UNSET_SCALAR, 0, workerIndex); + OP14( UNSET_SCALAR, 0, worker); OP14( UNSET_SCALAR, 0, infoIndex); INVOKE( RETURN_STK); FWDLABEL( end); @@ -1593,11 +1597,11 @@ CompileDictEachCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *varsTokenPtr, *dictTokenPtr, *bodyTokenPtr; - int keyVarIndex, valueVarIndex, nameChars, loopRange, catchRange; - int infoIndex, bodyTargetOffset, emptyTarget, endTarget; + Tcl_LVTIndex keyVarIndex, valueVarIndex, infoIndex, collectVar = -1; + int nameChars; + Tcl_ExceptionRange loopRange, catchRange; + Tcl_BytecodeLabel bodyTarget, emptyTarget, endTarget; Tcl_Size numVars; - int collectVar = -1; /* Index of temp var holding the result - * dict. */ const char **argv; Tcl_DString buffer; @@ -1608,6 +1612,9 @@ CompileDictEachCmd( if (parsePtr->numWords != 4) { return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } + if (!EnvHasLVT(envPtr)) { + return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); + } varsTokenPtr = TokenAfter(parsePtr->tokenPtr); dictTokenPtr = TokenAfter(varsTokenPtr); @@ -1687,75 +1694,69 @@ 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); + catchRange = MAKE_CATCH_RANGE(); OP4( BEGIN_CATCH, catchRange); - ExceptionRangeStarts(envPtr, catchRange); + CATCH_RANGE(catchRange) { + OP4( DICT_FIRST, infoIndex); + FWDJUMP( JUMP_TRUE, emptyTarget); - OP4( DICT_FIRST, infoIndex); - FWDJUMP( JUMP_TRUE, emptyTarget); - - /* - * Inside the iteration, write the loop variables. - */ + /* + * Inside the iteration, write the loop variables. + */ - BACKLABEL(bodyTargetOffset); - OP4( STORE_SCALAR, keyVarIndex); - OP( POP); - OP4( STORE_SCALAR, valueVarIndex); - OP( POP); + 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); + loopRange = MAKE_LOOP_RANGE(); - /* - * Compile the loop body itself. It should be stack-neutral. - */ + /* + * Compile the loop body itself. It should be stack-neutral. + */ - CATCH_RANGE(loopRange) { - BODY(bodyTokenPtr, 3); - if (collect == TCL_EACH_COLLECT) { - OP4( LOAD_SCALAR, keyVarIndex); - OP4( OVER, 1); - OP44( DICT_SET, 1, collectVar); + CATCH_RANGE(loopRange) { + BODY( bodyTokenPtr, 3); + if (collect == TCL_EACH_COLLECT) { + OP4( LOAD_SCALAR, keyVarIndex); + OP4( OVER, 1); + OP44( DICT_SET, 1, collectVar); + OP( POP); + } OP( POP); } - OP( POP); } /* - * Both exception target ranges (error and loop) end here. - */ - - ExceptionRangeEnds(envPtr, catchRange); - - /* * Continue (or just normally process) by getting the next pair of items * from the dictionary and jumping back to the code to write them into * variables if there is another pair. */ - ExceptionRangeTarget(envPtr, loopRange, continueOffset); + CONTINUE_TARGET( loopRange); OP4( DICT_NEXT, infoIndex); - BACKJUMP( JUMP_FALSE, bodyTargetOffset); + BACKJUMP( JUMP_FALSE, bodyTarget); FWDJUMP( JUMP, endTarget); + STKDELTA(-1); /* * Error handler "finally" clause, which force-terminates the iteration * and re-throws the error. */ - STKDELTA(-1); - ExceptionRangeTarget(envPtr, catchRange, catchOffset); + CATCH_TARGET( catchRange); OP( PUSH_RETURN_OPTIONS); OP( PUSH_RESULT); OP( END_CATCH); @@ -1775,8 +1776,8 @@ CompileDictEachCmd( FWDLABEL( endTarget); OP( POP); OP( POP); - ExceptionRangeTarget(envPtr, loopRange, breakOffset); - TclFinalizeLoopExceptionRange(envPtr, loopRange); + BREAK_TARGET( loopRange); + FINALIZE_LOOP(loopRange); OP( END_CATCH); /* @@ -1805,7 +1806,11 @@ TclCompileDictUpdateCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ - int i, dictIndex, numVars, range, infoIndex, done; + int i, numVars; + Tcl_AuxDataRef infoIndex; + Tcl_LVTIndex dictIndex; + Tcl_ExceptionRange range; + Tcl_BytecodeLabel done; Tcl_Token **keyTokenPtrs, *dictVarTokenPtr, *bodyTokenPtr, *tokenPtr; DictUpdateInfo *duiPtr; @@ -1884,12 +1889,12 @@ TclCompileDictUpdateCmd( infoIndex = TclCreateAuxData(duiPtr, &dictUpdateInfoType, envPtr); for (i=0 ; inumWords - 1); @@ -1901,7 +1906,7 @@ TclCompileDictUpdateCmd( */ OP( END_CATCH); - OP4( REVERSE, 2); + OP( SWAP); OP44( DICT_UPDATE_END, dictIndex, infoIndex); /* @@ -1916,7 +1921,7 @@ TclCompileDictUpdateCmd( * and finally return with the caught return data */ - ExceptionRangeTarget(envPtr, range, catchOffset); + CATCH_TARGET( range); OP( PUSH_RESULT); OP( PUSH_RETURN_OPTIONS); OP( END_CATCH); @@ -1951,7 +1956,8 @@ TclCompileDictAppendCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - int i, dictVarIndex; + int i; + Tcl_LVTIndex dictVarIndex; /* * There must be at least two argument after the command. And we impose an @@ -1980,7 +1986,7 @@ TclCompileDictAppendCmd( tokenPtr = TokenAfter(tokenPtr); for (i=2 ; i<(int)parsePtr->numWords ; i++) { - CompileWord(envPtr, tokenPtr, interp, i); + PUSH_TOKEN( tokenPtr, i); tokenPtr = TokenAfter(tokenPtr); } if ((int)parsePtr->numWords > 4) { @@ -2006,7 +2012,7 @@ TclCompileDictLappendCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr, *keyTokenPtr, *valueTokenPtr; - int dictVarIndex; + Tcl_LVTIndex dictVarIndex; /* * There must be three arguments after the command. @@ -2034,12 +2040,14 @@ TclCompileDictLappendCmd( * Issue the implementation. */ - CompileWord(envPtr, keyTokenPtr, interp, 2); - CompileWord(envPtr, valueTokenPtr, interp, 3); + PUSH_TOKEN( keyTokenPtr, 2); + PUSH_TOKEN( valueTokenPtr, 3); OP4( DICT_LAPPEND, dictVarIndex); return TCL_OK; } +/* Compile [dict with]. Delegates code issuing to CompileDictWithEmpty() and + * CompileDictWithBodied(). */ int TclCompileDictWithCmd( Tcl_Interp *interp, /* Used for looking up stuff. */ @@ -2049,10 +2057,7 @@ TclCompileDictWithCmd( * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { - DefineLineInformation; /* TIP #280 */ - int i, range, varNameTmp = -1, pathTmp = -1, keysTmp, gotPath; - int dictVar, bodyIsEmpty = 1, done; - int numWords = (int) parsePtr->numWords; + int i, bodyIsEmpty = 1, numWords = (int) parsePtr->numWords, chLen; Tcl_Token *varTokenPtr, *tokenPtr; const char *ptr, *end; @@ -2083,11 +2088,17 @@ TclCompileDictWithCmd( * Test if the last word is an empty script; if so, we can compile it in * all cases, but if it is non-empty we need local variable table entries * to hold the temporary variables (used to keep stack usage simple). + * + * We don't test if it's just comments. Fixes please, if you care. */ - 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) { + end = tokenPtr[1].start + tokenPtr[1].size; + for (ptr = tokenPtr[1].start; ptr < end; ptr += chLen) { + int ucs4; + chLen = TclUtfToUniChar(ptr, &ucs4); + + if (!Tcl_UniCharIsSpace(ucs4)) { + if (!EnvHasLVT(envPtr)) { return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr); } @@ -2096,13 +2107,38 @@ TclCompileDictWithCmd( } } - /* - * Determine if we're manipulating a dict in a simple local variable. - */ + /* Now we commit to issuing code. */ - gotPath = (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. + */ + + CompileDictWithEmpty(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. + */ + CompileDictWithBodied(interp, numWords, varTokenPtr, envPtr); + } + return TCL_OK; +} + +/* Issue code for a [dict with] that has an entirely trivial body. */ +static inline void +CompileDictWithEmpty( + Tcl_Interp *interp, + int numWords, + Tcl_Token *varTokenPtr, + CompileEnv *envPtr) +{ /* * 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 @@ -2111,70 +2147,88 @@ TclCompileDictWithCmd( * of traces. */ - if (bodyIsEmpty) { - if (dictVar >= 0) { - if (gotPath) { - /* - * Case: Path into dict in LVT with empty body. - */ + Tcl_Token *tokenPtr; + DefineLineInformation; /* TIP #280 */ + int i, gotPath; + Tcl_LVTIndex dictVar; - tokenPtr = TokenAfter(varTokenPtr); - for (i=2 ; i 3); + dictVar = LocalScalarFromToken(varTokenPtr, envPtr); + + if (dictVar >= 0) { + if (gotPath) { + /* + * Case: Path into dict in LVT with empty body. + */ + + tokenPtr = TokenAfter(varTokenPtr); + for (i=2 ; i 3); + dictVar = LocalScalarFromToken(varTokenPtr, envPtr); + if (dictVar == -1) { varNameTmp = AnonymousLocal(envPtr); } @@ -2196,27 +2264,30 @@ TclCompileDictWithCmd( */ if (dictVar == -1) { - CompileWord(envPtr, varTokenPtr, interp, 1); + PUSH_TOKEN( varTokenPtr, 1); OP4( STORE_SCALAR, varNameTmp); } tokenPtr = TokenAfter(varTokenPtr); if (gotPath) { for (i=2 ; i 3) { - OP4( LOAD_SCALAR, pathTmp); - } else { - PUSH( ""); - } - OP4( LOAD_SCALAR, keysTmp); - if (dictVar == -1) { + if (numWords > 3) { + OP4( LOAD_SCALAR, pathTmp); + } else { + PUSH( ""); + } + OP4( LOAD_SCALAR, keysTmp); OP( DICT_RECOMBINE_STK); } else { + if (numWords > 3) { + OP4( LOAD_SCALAR, pathTmp); + } else { + PUSH( ""); + } + OP4( LOAD_SCALAR, keysTmp); OP4( DICT_RECOMBINE_IMM, dictVar); } INVOKE( RETURN_STK); @@ -2285,7 +2363,6 @@ TclCompileDictWithCmd( */ FWDLABEL( done); - return TCL_OK; } /* @@ -2411,7 +2488,7 @@ 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. @@ -2422,13 +2499,13 @@ TclCompileErrorCmd( } else { PUSH( "-errorinfo"); tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 2); + PUSH_TOKEN( tokenPtr, 2); if (parsePtr->numWords == 3) { OP4( LIST, 2); } else { PUSH( "-errorcode"); tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 3); + PUSH_TOKEN( tokenPtr, 3); OP4( LIST, 4); } } @@ -2513,7 +2590,8 @@ TclCompileForCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *startTokenPtr, *testTokenPtr, *nextTokenPtr, *bodyTokenPtr; - int evalBody, testCondition, evalNext, bodyRange, nextRange; + Tcl_ExceptionRange bodyRange, nextRange; + Tcl_BytecodeLabel evalBody, testCondition; if (parsePtr->numWords != 5) { return TCL_ERROR; @@ -2568,7 +2646,7 @@ TclCompileForCmd( * Compile the loop body. */ - bodyRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); + bodyRange = MAKE_LOOP_RANGE(); BACKLABEL( evalBody); CATCH_RANGE(bodyRange) { BODY( bodyTokenPtr, 4); @@ -2581,9 +2659,9 @@ TclCompileForCmd( * TCL_CONTINUE but rather just TCL_BREAK. */ - nextRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); + nextRange = MAKE_LOOP_RANGE(); envPtr->exceptAuxArrayPtr[nextRange].supportsContinue = 0; - BACKLABEL( evalNext); + CONTINUE_TARGET( bodyRange); CATCH_RANGE(nextRange) { BODY( nextTokenPtr, 3); } @@ -2595,9 +2673,7 @@ TclCompileForCmd( */ FWDLABEL( testCondition); - SetLineInformation(2); - TclCompileExprWords(interp, testTokenPtr, 1, envPtr); - + PUSH_EXPR_TOKEN( testTokenPtr, 2); BACKJUMP( JUMP_TRUE, evalBody); /* @@ -2605,15 +2681,10 @@ TclCompileForCmd( * jump type modification) and set where the exceptions target. */ - envPtr->exceptArrayPtr[bodyRange].codeOffset = evalBody; - envPtr->exceptArrayPtr[bodyRange].continueOffset = evalNext; - - envPtr->exceptArrayPtr[nextRange].codeOffset = evalNext; - - ExceptionRangeTarget(envPtr, bodyRange, breakOffset); - ExceptionRangeTarget(envPtr, nextRange, breakOffset); - TclFinalizeLoopExceptionRange(envPtr, bodyRange); - TclFinalizeLoopExceptionRange(envPtr, nextRange); + BREAK_TARGET( bodyRange); + BREAK_TARGET( nextRange); + FINALIZE_LOOP(bodyRange); + FINALIZE_LOOP(nextRange); /* * The for command's result is an empty string. @@ -2714,14 +2785,14 @@ 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; + int jumpBackOffset, numWords, numLists, i, code = TCL_OK; + Tcl_AuxDataRef infoIndex; + Tcl_ExceptionRange range; Tcl_Size j; Tcl_Obj *varListObj = NULL; @@ -2730,7 +2801,7 @@ CompileEachloopCmd( * the payoff is too small. */ - if (procPtr == NULL) { + if (envPtr->procPtr == NULL) { return TCL_ERROR; } @@ -2796,13 +2867,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); @@ -2839,7 +2910,7 @@ CompileEachloopCmd( i < numWords-1; i++, tokenPtr = TokenAfter(tokenPtr)) { if ((i%2 == 0) && (i > 0)) { - CompileWord(envPtr, tokenPtr, interp, i); + PUSH_TOKEN( tokenPtr, i); } } @@ -2849,7 +2920,7 @@ CompileEachloopCmd( * Inline compile the loop body. */ - range = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); + range = MAKE_LOOP_RANGE(); CATCH_RANGE(range) { BODY( bodyTokenPtr, numWords - 1); @@ -2866,12 +2937,12 @@ CompileEachloopCmd( * to terminate the loop. Set the loop's break target. */ - ExceptionRangeTarget(envPtr, range, continueOffset); + CONTINUE_TARGET( range); OP( FOREACH_STEP); - ExceptionRangeTarget(envPtr, range, breakOffset); - TclFinalizeLoopExceptionRange(envPtr, range); + BREAK_TARGET( range); + FINALIZE_LOOP(range); OP( FOREACH_END); - STKDELTA(-(numLists+2)); + STKDELTA(-(numLists + 2)); /* * Set the jumpback distance from INST_FOREACH_STEP to the start of the @@ -2891,7 +2962,7 @@ CompileEachloopCmd( PUSH( ""); } - done: + done: if (code == TCL_ERROR) { FreeForeachInfo(infoPtr); } @@ -3186,7 +3257,6 @@ TclCompileFormatCmd( Tcl_Obj **objv, *formatObj, *tmpObj; const char *bytes, *start; int i, j; - Tcl_Size len; /* * Don't handle any guaranteed-error cases. @@ -3209,7 +3279,7 @@ TclCompileFormatCmd( return TCL_ERROR; } - objv = (Tcl_Obj **)Tcl_Alloc(((int)parsePtr->numWords-2) * sizeof(Tcl_Obj *)); + objv = (Tcl_Obj **)TclStackAlloc(interp, (parsePtr->numWords-2) * sizeof(Tcl_Obj *)); for (i=0 ; i+2 < (int)parsePtr->numWords ; i++) { tokenPtr = TokenAfter(tokenPtr); TclNewObj(objv[i]); @@ -3229,7 +3299,7 @@ TclCompileFormatCmd( for (; --i>=0 ;) { Tcl_DecrRefCount(objv[i]); } - Tcl_Free(objv); + TclStackFree(interp, objv); Tcl_DecrRefCount(formatObj); if (tmpObj == NULL) { TclCompileSyntaxError(interp, envPtr); @@ -3241,9 +3311,7 @@ TclCompileFormatCmd( * literal. Job done. */ - bytes = TclGetStringFromObj(tmpObj, &len); - PushLiteral(envPtr, bytes, len); - Tcl_DecrRefCount(tmpObj); + PUSH_OBJ( tmpObj); return TCL_OK; checkForStringConcatCase: @@ -3259,7 +3327,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; @@ -3312,16 +3380,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++; } @@ -3332,7 +3397,7 @@ TclCompileFormatCmd( * directly. */ - CompileWord(envPtr, tokenPtr, interp, j); + PUSH_TOKEN( tokenPtr, j); tokenPtr = TokenAfter(tokenPtr); j++; i++; @@ -3346,12 +3411,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) { @@ -3389,7 +3453,8 @@ TclLocalScalarFromToken( Tcl_Token *tokenPtr, CompileEnv *envPtr) { - int isScalar, index; + int isScalar; + Tcl_LVTIndex index; TclPushVarName(NULL, tokenPtr, envPtr, TCL_NO_ELEMENT, &index, &isScalar); if (!isScalar) { @@ -3457,9 +3522,9 @@ TclPushVarName( Tcl_Size n; Tcl_Token *elemTokenPtr = NULL; size_t nameLen, elNameLen; - int simpleVarName, localIndex; + int simpleVarName, allocedTokens = 0; Tcl_Size elemTokenCount = 0, removedParen = 0; - int allocedTokens = 0; + Tcl_LVTIndex localIndex; /* * Decide if we can use a frame slot for the var/array name or if we need diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 1492483..a3249ce 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); /* @@ -92,7 +92,8 @@ TclCompileGlobalCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr; - int localIndex, numWords, i; + Tcl_LVTIndex localIndex; + int numWords, i; /* TODO: Consider support for compiling expanded args. */ numWords = parsePtr->numWords; @@ -132,7 +133,7 @@ TclCompileGlobalCmd( * apply here. Push known value instead. */ - CompileWord(envPtr, varTokenPtr, interp, i); + PUSH_TOKEN( varTokenPtr, i); OP4( NSUPVAR, localIndex); } @@ -195,7 +196,6 @@ TclCompileIfCmd( */ tokenPtr = parsePtr->tokenPtr; - wordIdx = 0; numWords = parsePtr->numWords; for (wordIdx = 0; wordIdx < numWords; wordIdx++) { @@ -263,9 +263,8 @@ 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); } @@ -444,7 +443,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)) { @@ -471,14 +471,13 @@ TclCompileIncrCmd( int code; Tcl_Obj *intObj = Tcl_NewStringObj(word, numBytes); - Tcl_IncrRefCount(intObj); code = TclGetWideIntFromObj(NULL, intObj, &immValue); if ((code == TCL_OK) && (-127 <= immValue) && (immValue <= 127)) { haveImmValue = 1; } - TclDecrRefCount(intObj); + Tcl_BounceRefCount(intObj); if (!haveImmValue) { - PushLiteral(envPtr, word, numBytes); + PUSH_SIMPLE_TOKEN(incrTokenPtr); } } else { SetLineInformation(2); @@ -556,7 +555,7 @@ TclCompileInfoCommandsCmd( Tcl_Token *tokenPtr; Tcl_Obj *objPtr; const char *bytes; - int isList; + Tcl_BytecodeLabel isList; /* * We require one compile-time known argument for the case we can compile. @@ -592,7 +591,7 @@ TclCompileInfoCommandsCmd( */ /* TODO: Just push the known value */ - CompileWord(envPtr, tokenPtr, interp, 1); + PUSH_TOKEN( tokenPtr, 1); OP( RESOLVE_COMMAND); OP( DUP); OP( STR_LEN); @@ -640,7 +639,8 @@ TclCompileInfoExistsCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - int isScalar, localIndex; + int isScalar; + Tcl_LVTIndex localIndex; if (parsePtr->numWords != 2) { return TCL_ERROR; @@ -706,7 +706,7 @@ TclCompileInfoLevelCmd( * list of arguments. */ - CompileWord(envPtr, TokenAfter(parsePtr->tokenPtr), interp, 1); + PUSH_TOKEN( TokenAfter(parsePtr->tokenPtr), 1); OP( INFO_LEVEL_ARGS); } return TCL_OK; @@ -726,7 +726,7 @@ TclCompileInfoObjectClassCmd( if (parsePtr->numWords != 2) { return TCL_ERROR; } - CompileWord(envPtr, tokenPtr, interp, 1); + PUSH_TOKEN( tokenPtr, 1); OP( TCLOO_CLASS); return TCL_OK; } @@ -761,7 +761,7 @@ TclCompileInfoObjectIsACmd( * Issue the code. */ - CompileWord(envPtr, tokenPtr, interp, 2); + PUSH_TOKEN( tokenPtr, 2); OP( TCLOO_IS_OBJECT); return TCL_OK; } @@ -780,7 +780,7 @@ TclCompileInfoObjectNamespaceCmd( if (parsePtr->numWords != 2) { return TCL_ERROR; } - CompileWord(envPtr, tokenPtr, interp, 1); + PUSH_TOKEN( tokenPtr, 1); OP( TCLOO_NS); return TCL_OK; } @@ -813,7 +813,8 @@ TclCompileLappendCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr, *valueTokenPtr; - int isScalar, localIndex, numWords, i; + int isScalar, numWords, i; + Tcl_LVTIndex localIndex; /* TODO: Consider support for compiling expanded args. */ numWords = parsePtr->numWords; @@ -821,7 +822,7 @@ TclCompileLappendCmd( return TCL_ERROR; } - if (numWords != 3 || envPtr->procPtr == NULL) { + if (numWords != 3 || !EnvHasLVT(envPtr)) { goto lappendMultiple; } @@ -845,8 +846,7 @@ TclCompileLappendCmd( if (numWords > 2) { valueTokenPtr = TokenAfter(varTokenPtr); - - CompileWord(envPtr, valueTokenPtr, interp, 2); + PUSH_TOKEN( valueTokenPtr, 2); } /* @@ -880,7 +880,7 @@ TclCompileLappendCmd( &localIndex, &isScalar, 1); valueTokenPtr = TokenAfter(varTokenPtr); for (i = 2 ; i < numWords ; i++) { - CompileWord(envPtr, valueTokenPtr, interp, i); + PUSH_TOKEN( valueTokenPtr, i); valueTokenPtr = TokenAfter(valueTokenPtr); } OP4( LIST, numWords - 2); @@ -928,7 +928,8 @@ TclCompileLassignCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - int isScalar, localIndex, numWords, idx; + int isScalar, numWords, idx; + Tcl_LVTIndex localIndex; numWords = parsePtr->numWords; @@ -945,7 +946,7 @@ TclCompileLassignCmd( */ tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); + PUSH_TOKEN( tokenPtr, 1); /* * Generate code to assign values from the list to variables. @@ -1057,7 +1058,7 @@ TclCompileLindexCmd( * same result as indexing after a list. */ - CompileWord(envPtr, valTokenPtr, interp, 1); + PUSH_TOKEN( valTokenPtr, 1); OP4( LIST_INDEX_IMM, idx); return TCL_OK; } @@ -1074,7 +1075,7 @@ TclCompileLindexCmd( emitComplexLindex: for (i=1 ; itype == TCL_TOKEN_EXPAND_WORD) { if (concat) { OP( LIST_CONCAT); @@ -1238,7 +1239,7 @@ TclCompileLlengthCmd( } varTokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, varTokenPtr, interp, 1); + PUSH_TOKEN( varTokenPtr, 1); OP( LIST_LENGTH); return TCL_OK; } @@ -1297,7 +1298,7 @@ TclCompileLrangeCmd( * is worth trying to do that given current knowledge. */ - CompileWord(envPtr, listTokenPtr, interp, 1); + PUSH_TOKEN( listTokenPtr, 1); OP44( LIST_RANGE_IMM, idx1, idx2); return TCL_OK; } @@ -1322,23 +1323,24 @@ TclCompileLinsertCmd( CompileEnv *envPtr) /* Holds the resulting instructions. */ { DefineLineInformation; /* TIP #280 */ - Tcl_Token *tokenPtr; - int i; + Tcl_Token *listToken, *indexToken, *tokenPtr; + Tcl_Size i; - if ((int)parsePtr->numWords < 3) { + if (parsePtr->numWords < 3 || parsePtr->numWords > 0x7FFFFFFF) { 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 ; inumWords ; i++,tokenPtr=TokenAfter(tokenPtr)) { + PUSH_TOKEN( tokenPtr, i); } /* @@ -1350,7 +1352,6 @@ TclCompileLinsertCmd( */ OP41( LREPLACE, parsePtr->numWords - 1, TCL_LREPLACE4_SINGLE_INDEX); - return TCL_OK; } @@ -1374,25 +1375,26 @@ TclCompileLreplaceCmd( CompileEnv *envPtr) /* Holds the resulting instructions. */ { DefineLineInformation; /* TIP #280 */ - Tcl_Token *tokenPtr; - int i; + Tcl_Token *listToken, *firstToken, *lastToken, *tokenPtr; + Tcl_Size i; - if (parsePtr->numWords < 4) { + if (parsePtr->numWords < 4 || parsePtr->numWords > 0x7FFFFFFF) { 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; inumWords; i++,tokenPtr=TokenAfter(tokenPtr)) { + PUSH_TOKEN( tokenPtr, i); } /* @@ -1458,7 +1460,7 @@ TclCompileLsetCmd( * 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; @@ -1493,7 +1495,7 @@ TclCompileLsetCmd( for (i=2 ; i<(int)parsePtr->numWords ; ++i) { varTokenPtr = TokenAfter(varTokenPtr); - CompileWord(envPtr, varTokenPtr, interp, i); + PUSH_TOKEN( varTokenPtr, i); } /* @@ -1659,7 +1661,7 @@ TclCompileNamespaceCodeCmd( PUSH( "::namespace"); PUSH( "inscope"); OP( NS_CURRENT); - CompileWord(envPtr, tokenPtr, interp, 1); + PUSH_TOKEN( tokenPtr, 1); OP4( LIST, 4); return TCL_OK; } @@ -1680,7 +1682,7 @@ TclCompileNamespaceOriginCmd( } tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); + PUSH_TOKEN( tokenPtr, 1); OP( ORIGIN_COMMAND); return TCL_OK; } @@ -1695,13 +1697,13 @@ 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); + PUSH_TOKEN( tokenPtr, 1); PUSH( "0"); PUSH( "::"); OP4( OVER, 2); @@ -1729,7 +1731,7 @@ TclCompileNamespaceTailCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); - int offset; + Tcl_BytecodeLabel dontSkipSeparator; if (parsePtr->numWords != 2) { return TCL_ERROR; @@ -1739,17 +1741,17 @@ TclCompileNamespaceTailCmd( * Take care; only add 2 to found index if the string was actually found. */ - CompileWord(envPtr, tokenPtr, interp, 1); + PUSH_TOKEN( tokenPtr, 1); PUSH( "::"); OP4( OVER, 1); OP( STR_FIND_LAST); OP( DUP); PUSH( "0"); OP( GE); - FWDJUMP( JUMP_FALSE, offset); + FWDJUMP( JUMP_FALSE, dontSkipSeparator); PUSH( "2"); OP( ADD); - FWDLABEL( offset); + FWDLABEL( dontSkipSeparator); PUSH( "end"); OP( STR_RANGE); return TCL_OK; @@ -1765,7 +1767,8 @@ TclCompileNamespaceUpvarCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr, *otherTokenPtr, *localTokenPtr; - int localIndex, numWords, i; + Tcl_LVTIndex localIndex; + int numWords, i; if (envPtr->procPtr == NULL) { return TCL_ERROR; @@ -1785,7 +1788,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 @@ -1798,7 +1801,7 @@ 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; @@ -1855,7 +1858,7 @@ TclCompileNamespaceWhichCmd( * Issue the bytecode. */ - CompileWord(envPtr, tokenPtr, interp, idx); + PUSH_TOKEN( tokenPtr, idx); OP( RESOLVE_COMMAND); return TCL_OK; } @@ -1988,13 +1991,13 @@ TclCompileRegexpCmd( if (TclReToGlob(NULL, varTokenPtr[1].start, 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, (int)parsePtr->numWords - 2); } /* @@ -2002,7 +2005,7 @@ TclCompileRegexpCmd( */ varTokenPtr = TokenAfter(varTokenPtr); - CompileWord(envPtr, varTokenPtr, interp, (int)parsePtr->numWords - 1); + PUSH_TOKEN( varTokenPtr, (int)parsePtr->numWords - 1); if (simple) { if (exact && !nocase) { @@ -2184,9 +2187,8 @@ 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); + PUSH_OBJ( replacementObj); + PUSH_TOKEN( stringTokenPtr, (int)parsePtr->numWords - 2); OP( STR_MAP); done: @@ -2195,7 +2197,7 @@ TclCompileRegsubCmd( Tcl_DecrRefCount(patternObj); } if (replacementObj) { - Tcl_DecrRefCount(replacementObj); + Tcl_BounceRefCount(replacementObj); } return result; } @@ -2254,8 +2256,8 @@ TclCompileReturnCmd( Tcl_Token *optsTokenPtr = TokenAfter(wordTokenPtr); Tcl_Token *msgTokenPtr = TokenAfter(optsTokenPtr); - CompileWord(envPtr, optsTokenPtr, interp, 2); - CompileWord(envPtr, msgTokenPtr, interp, 3); + PUSH_TOKEN( optsTokenPtr, 2); + PUSH_TOKEN( msgTokenPtr, 3); INVOKE( RETURN_STK); return TCL_OK; } @@ -2315,7 +2317,7 @@ 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. @@ -2335,7 +2337,7 @@ TclCompileReturnCmd( * 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) { @@ -2383,7 +2385,7 @@ TclCompileReturnCmd( wordTokenPtr = TokenAfter(parsePtr->tokenPtr); for (objc=1 ; objc<=numOptionWords ; objc++) { - CompileWord(envPtr, wordTokenPtr, interp, objc); + PUSH_TOKEN( wordTokenPtr, objc); wordTokenPtr = TokenAfter(wordTokenPtr); } OP4( LIST, numOptionWords); @@ -2393,7 +2395,7 @@ TclCompileReturnCmd( */ if (explicitResult) { - CompileWord(envPtr, wordTokenPtr, interp, numWords - 1); + PUSH_TOKEN( wordTokenPtr, numWords - 1); } else { PUSH( ""); } @@ -2431,7 +2433,7 @@ CompileReturnInternal( } } - TclEmitPush(TclAddLiteralObj(envPtr, returnOpts, NULL), envPtr); + PUSH_OBJ( returnOpts); TclEmitInstInt44(op, code, level, envPtr); } @@ -2479,14 +2481,15 @@ TclCompileUpvarCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr, *otherTokenPtr, *localTokenPtr; - int localIndex, numWords, i; + Tcl_LVTIndex localIndex; + int numWords, i; Tcl_Obj *objPtr; if (envPtr->procPtr == NULL) { return TCL_ERROR; } - numWords = parsePtr->numWords; + numWords = (int) parsePtr->numWords; if (numWords < 3) { return TCL_ERROR; } @@ -2511,15 +2514,15 @@ TclCompileUpvarCmd( Tcl_DecrRefCount(objPtr); if (newTypePtr != typePtr) { - if (numWords%2) { + 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; } PUSH( "1"); @@ -2540,7 +2543,7 @@ TclCompileUpvarCmd( for (; inumWords; if (numWords < 2) { @@ -2618,7 +2622,7 @@ 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); + PUSH_TOKEN( varTokenPtr, i); OP4( VARIABLE, localIndex); if (i + 1 < numWords) { @@ -2626,7 +2630,7 @@ TclCompileVariableCmd( * A value has been given: set the variable, pop the value */ - CompileWord(envPtr, valueTokenPtr, interp, i + 1); + PUSH_TOKEN( valueTokenPtr, i + 1); OP4( STORE_SCALAR, localIndex); OP( POP); } @@ -2659,7 +2663,7 @@ TclCompileVariableCmd( *---------------------------------------------------------------------- */ -static int +static Tcl_LVTIndex IndexTailVarIfKnown( TCL_UNUSED(Tcl_Interp *), Tcl_Token *varTokenPtr, /* Token representing the variable name */ @@ -2670,7 +2674,8 @@ IndexTailVarIfKnown( int n = varTokenPtr->numComponents; Tcl_Size 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 @@ -2762,7 +2767,7 @@ TclCompileObjectNextCmd( int i; for (i=0 ; i<(int)parsePtr->numWords ; i++) { - CompileWord(envPtr, tokenPtr, interp, i); + PUSH_TOKEN( tokenPtr, i); tokenPtr = TokenAfter(tokenPtr); } TclEmitInvoke(envPtr, INST_TCLOO_NEXT, i); @@ -2786,7 +2791,7 @@ TclCompileObjectNextToCmd( } for (i=0 ; i<(int)parsePtr->numWords ; i++) { - CompileWord(envPtr, tokenPtr, interp, i); + PUSH_TOKEN( tokenPtr, i); tokenPtr = TokenAfter(tokenPtr); } TclEmitInvoke(envPtr, INST_TCLOO_NEXT_CLASS, i); diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 58db547..770efbd 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -20,6 +20,18 @@ #include "tclStringTrim.h" /* + * 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 -1 for none. + Tcl_LVTIndex optionVar; // The option variable index, or -1 for none. +} TryHandlerInfo; + +/* * Prototypes for procedures defined later in this file: */ @@ -49,14 +61,10 @@ static void IssueSwitchJumpTable(Tcl_Interp *interp, Tcl_Size **bodyContLines); 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); + int 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, + int numHandlers, TryHandlerInfo *handlers, Tcl_Token *finallyToken); static int IssueTryFinallyInstructions(Tcl_Interp *interp, CompileEnv *envPtr, Tcl_Token *bodyToken, @@ -102,7 +110,8 @@ TclCompileSetCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr, *valueTokenPtr; - int isAssignment, isScalar, localIndex, numWords; + int isAssignment, isScalar, numWords; + Tcl_LVTIndex localIndex; numWords = parsePtr->numWords; if ((numWords != 2) && (numWords != 3)) { @@ -128,7 +137,7 @@ TclCompileSetCmd( if (isAssignment) { valueTokenPtr = TokenAfter(varTokenPtr); - CompileWord(envPtr, valueTokenPtr, interp, 2); + PUSH_TOKEN( valueTokenPtr, 2); } /* @@ -137,21 +146,31 @@ TclCompileSetCmd( if (isScalar) { if (localIndex < 0) { - TclEmitOpcode((isAssignment? - INST_STORE_STK : INST_LOAD_STK), envPtr); + if (isAssignment) { + OP( STORE_STK); + } else { + OP( LOAD_STK); + } } else { - TclEmitInstInt4((isAssignment? - INST_STORE_SCALAR : INST_LOAD_SCALAR), - localIndex, envPtr); + if (isAssignment) { + OP4( STORE_SCALAR, localIndex); + } else { + OP4( LOAD_SCALAR, localIndex); + } } } else { if (localIndex < 0) { - TclEmitOpcode((isAssignment? - INST_STORE_ARRAY_STK : INST_LOAD_ARRAY_STK), envPtr); + if (isAssignment) { + OP( STORE_ARRAY_STK); + } else { + OP( LOAD_ARRAY_STK); + } } else { - TclEmitInstInt4((isAssignment? - INST_STORE_ARRAY : INST_LOAD_ARRAY), - localIndex, envPtr); + if (isAssignment) { + OP4( STORE_ARRAY, localIndex); + } else { + OP4( LOAD_ARRAY, localIndex); + } } } @@ -208,22 +227,18 @@ 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 ++; } - CompileWord(envPtr, wordTokenPtr, interp, i); + PUSH_TOKEN( wordTokenPtr, i); numArgs ++; if (numArgs >= 254) { /* 254 to take care of the possible +1 of "folded" above */ OP1( STR_CONCAT1, numArgs); @@ -233,11 +248,7 @@ TclCompileStringCatCmd( 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 ++; } @@ -257,7 +268,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. @@ -271,10 +282,10 @@ 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); + aTokenPtr = TokenAfter(parsePtr->tokenPtr); + bTokenPtr = TokenAfter(aTokenPtr); + PUSH_TOKEN( aTokenPtr, 1); + PUSH_TOKEN( bTokenPtr, 2); OP( STR_CMP); return TCL_OK; } @@ -288,7 +299,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. @@ -302,10 +313,10 @@ 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); + aTokenPtr = TokenAfter(parsePtr->tokenPtr); + bTokenPtr = TokenAfter(aTokenPtr); + PUSH_TOKEN( aTokenPtr, 1); + PUSH_TOKEN( bTokenPtr, 2); OP( STR_EQ); return TCL_OK; } @@ -319,7 +330,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. @@ -333,10 +344,10 @@ 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); + needleToken = TokenAfter(parsePtr->tokenPtr); + haystackToken = TokenAfter(needleToken); + PUSH_TOKEN( needleToken, 1); + PUSH_TOKEN( haystackToken, 2); OP( STR_FIND); return TCL_OK; } @@ -350,7 +361,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. @@ -364,10 +375,10 @@ 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); + needleToken = TokenAfter(parsePtr->tokenPtr); + haystackToken = TokenAfter(needleToken); + PUSH_TOKEN( needleToken, 1); + PUSH_TOKEN( haystackToken, 2); OP( STR_FIND_LAST); return TCL_OK; } @@ -381,7 +392,7 @@ TclCompileStringIndexCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ - Tcl_Token *tokenPtr; + Tcl_Token *aTokenPtr, *bTokenPtr; if (parsePtr->numWords != 3) { return TCL_ERROR; @@ -391,10 +402,10 @@ 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); + aTokenPtr = TokenAfter(parsePtr->tokenPtr); + bTokenPtr = TokenAfter(aTokenPtr); + PUSH_TOKEN( aTokenPtr, 1); + PUSH_TOKEN( bTokenPtr, 2); OP( STR_INDEX); return TCL_OK; } @@ -408,48 +419,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; @@ -482,7 +491,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; @@ -536,7 +547,7 @@ TclCompileStringIsCmd( * 5. Lists */ - CompileWord(envPtr, tokenPtr, interp, (int)parsePtr->numWords-1); + PUSH_TOKEN( tokenPtr, (int)parsePtr->numWords - 1); switch (t) { case STR_IS_ALNUM: @@ -581,7 +592,7 @@ TclCompileStringIsCmd( if (allowEmpty) { OP1( STR_CLASS, strClassType); } else { - int over, over2; + Tcl_BytecodeLabel over, over2; OP( DUP); OP1( STR_CLASS, strClassType); @@ -601,7 +612,7 @@ TclCompileStringIsCmd( case STR_IS_TRUE: OP( TRY_CVT_TO_BOOLEAN); switch (t) { - int over, over2; + Tcl_BytecodeLabel over, over2; case STR_IS_BOOL: if (allowEmpty) { @@ -614,7 +625,7 @@ TclCompileStringIsCmd( PUSH( "1"); FWDLABEL(over2); } else { - OP4( REVERSE, 2); + OP( SWAP); OP( POP); } return TCL_OK; @@ -649,7 +660,7 @@ TclCompileStringIsCmd( break; case STR_IS_DOUBLE: { - int satisfied, isEmpty; + Tcl_BytecodeLabel satisfied, isEmpty; if (allowEmpty) { OP( DUP); @@ -680,7 +691,7 @@ TclCompileStringIsCmd( case STR_IS_WIDE: case STR_IS_ENTIER: if (allowEmpty) { - int testNumType; + Tcl_BytecodeLabel testNumType; OP( DUP); OP( NUM_TYPE); @@ -692,7 +703,7 @@ TclCompileStringIsCmd( FWDJUMP( JUMP, end); STKDELTA(+1); FWDLABEL( testNumType); - OP4( REVERSE, 2); + OP( SWAP); OP( POP); } else { OP( NUM_TYPE); @@ -716,27 +727,27 @@ TclCompileStringIsCmd( FWDLABEL( end); return TCL_OK; case STR_IS_DICT: - range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); + range = MAKE_CATCH_RANGE(); OP4( BEGIN_CATCH, range); OP( DUP); CATCH_RANGE(range) { OP( DICT_VERIFY); } - ExceptionRangeTarget(envPtr, range, catchOffset); + 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); + range = MAKE_CATCH_RANGE(); OP4( BEGIN_CATCH, range); OP( DUP); CATCH_RANGE(range) { OP( LIST_LENGTH); } OP( POP); - ExceptionRangeTarget(envPtr, range, catchOffset); + CATCH_TARGET( range); OP( POP); OP( PUSH_RETURN_CODE); OP( END_CATCH); @@ -758,9 +769,7 @@ TclCompileStringMatchCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - size_t length; int i, exactMatch = 0, nocase = 0; - const char *str; if (parsePtr->numWords < 3 || parsePtr->numWords > 4) { return TCL_ERROR; @@ -772,12 +781,12 @@ TclCompileStringMatchCmd( */ if (parsePtr->numWords == 4) { + size_t length; 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 ((length <= 1) || strncmp(tokenPtr[1].start, "-nocase", length)) { /* * Fail at run time, not in compilation. */ @@ -794,8 +803,6 @@ 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 @@ -803,13 +810,13 @@ TclCompileStringMatchCmd( * support for nocase. */ - Tcl_Obj *copy = Tcl_NewStringObj(str, length); + Tcl_Obj *copy = Tcl_NewStringObj(tokenPtr[1].start, + tokenPtr[1].size); - Tcl_IncrRefCount(copy); exactMatch = TclMatchIsTrivial(TclGetString(copy)); - TclDecrRefCount(copy); + Tcl_BounceRefCount(copy); } - PushLiteral(envPtr, str, length); + PUSH_SIMPLE_TOKEN( tokenPtr); } else { SetLineInformation(i+1+nocase); CompileTokens(envPtr, tokenPtr, interp); @@ -854,11 +861,8 @@ 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); @@ -880,8 +884,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: @@ -917,14 +920,12 @@ 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); + PUSH_OBJ( objv[0]); + PUSH_OBJ( objv[1]); + PUSH_TOKEN( stringTokenPtr, 2); OP( STR_MAP); } Tcl_DecrRefCount(mapObj); @@ -951,7 +952,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. @@ -1000,8 +1001,8 @@ TclCompileStringRangeCmd( */ nonConstantIndices: - CompileWord(envPtr, fromTokenPtr, interp, 2); - CompileWord(envPtr, toTokenPtr, interp, 3); + PUSH_TOKEN( fromTokenPtr, 2); + PUSH_TOKEN( toTokenPtr, 3); OP( STR_RANGE); return TCL_OK; } @@ -1024,7 +1025,7 @@ TclCompileStringReplaceCmd( /* 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. @@ -1085,7 +1086,7 @@ TclCompileStringReplaceCmd( && (last < first))) { /* Know (last < first) */ if (parsePtr->numWords == 5) { tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 4); + PUSH_TOKEN( tokenPtr, 4); OP( POP); /* Pop newString */ } /* Original string argument now on TOS as result */ @@ -1093,69 +1094,68 @@ TclCompileStringReplaceCmd( } 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 @@ -1177,31 +1177,31 @@ TclCompileStringReplaceCmd( } 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, 0, first - 1); + OP( SWAP); OP44( STR_RANGE_IMM, last + 1, (int)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 @@ -1220,12 +1220,12 @@ 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); return TCL_OK; @@ -1247,12 +1247,12 @@ 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); return TCL_OK; @@ -1274,12 +1274,12 @@ 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); return TCL_OK; @@ -1302,7 +1302,7 @@ TclCompileStringToUpperCmd( } tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); + PUSH_TOKEN( tokenPtr, 1); OP( STR_UPPER); return TCL_OK; } @@ -1324,7 +1324,7 @@ TclCompileStringToLowerCmd( } tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); + PUSH_TOKEN( tokenPtr, 1); OP( STR_LOWER); return TCL_OK; } @@ -1346,7 +1346,7 @@ TclCompileStringToTitleCmd( } tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); + PUSH_TOKEN( tokenPtr, 1); OP( STR_TITLE); return TCL_OK; } @@ -1466,7 +1466,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; @@ -1482,7 +1482,8 @@ TclSubstCompile( CompileEnv *envPtr) { Tcl_Token *endTokenPtr, *tokenPtr; - int breakOffset = 0, count = 0; + Tcl_BytecodeLabel breakOffset = 0; + int count = 0; Tcl_Size bline = line; Tcl_Parse parse; Tcl_InterpState state = NULL; @@ -1502,15 +1503,17 @@ 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, end; - int haveOk, haveReturn, haveBreak, haveContinue, haveOther; + int literal; + Tcl_ExceptionRange catchRange; + Tcl_BytecodeLabel end, haveOk, haveReturn, haveBreak, haveContinue; + Tcl_BytecodeLabel haveOther; char buf[4] = ""; switch (tokenPtr->type) { @@ -1570,7 +1573,7 @@ TclSubstCompile( } if (breakOffset == 0) { - int start; + Tcl_BytecodeLabel start; /* Jump to the start (jump over the jump to end) */ FWDJUMP( JUMP, start); @@ -1582,7 +1585,7 @@ TclSubstCompile( } envPtr->line = bline; - catchRange = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); + catchRange = MAKE_CATCH_RANGE(); OP4( BEGIN_CATCH, catchRange); CATCH_RANGE(catchRange) { switch (tokenPtr->type) { @@ -1607,7 +1610,7 @@ TclSubstCompile( STKDELTA(-1); /* Exceptional return codes processed here */ - ExceptionRangeTarget(envPtr, catchRange, catchOffset); + CATCH_TARGET( catchRange); OP( PUSH_RETURN_OPTIONS); OP( PUSH_RESULT); OP( PUSH_RETURN_CODE); @@ -1657,7 +1660,7 @@ TclSubstCompile( * Pull the result to top of stack, discard options dict. */ - OP4( REVERSE, 2); + OP( SWAP); OP( POP); /* OK destination */ @@ -1894,12 +1897,12 @@ 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); + bodyContLines = (Tcl_Size **)TclStackAlloc(interp, sizeof(Tcl_Size*) * maxLen); + bodyLines = (Tcl_Size *)TclStackAlloc(interp, sizeof(Tcl_Size) * maxLen); + bodyToken = (Tcl_Token **)TclStackAlloc(interp, sizeof(Tcl_Token *) * maxLen); - bline = mapPtr->loc[eclIndex].line[valueIndex+1]; + bline = ExtCmdLocation.line[valueIndex + 1]; numWords = 0; while (numBytes > 0) { @@ -1909,7 +1912,7 @@ TclCompileSwitchCmd( if (TCL_OK != TclFindElement(NULL, bytes, numBytes, &(bodyTokenArray[numWords].start), &bytes, &(bodyTokenArray[numWords].size), &literal) || !literal) { - goto abort; + goto freeTemporaries; } bodyTokenArray[numWords].type = TCL_TOKEN_TEXT; @@ -1934,12 +1937,7 @@ TclCompileSwitchCmd( 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) { /* @@ -1956,10 +1954,10 @@ 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; + bodyContLines = (Tcl_Size **)TclStackAlloc(interp, sizeof(Tcl_Size*) * numWords); + bodyLines = (Tcl_Size *)TclStackAlloc(interp, sizeof(Tcl_Size) * numWords); + bodyToken = (Tcl_Token **)TclStackAlloc(interp, sizeof(Tcl_Token *) * numWords); for (i=0 ; iloc[eclIndex].line[valueIndex+1+i]; - bodyContLines[i] = mapPtr->loc[eclIndex].next[valueIndex+1+i]; + bodyLines[i] = ExtCmdLocation.line[valueIndex + 1 + i]; + bodyContLines[i] = ExtCmdLocation.next[valueIndex + 1 + i]; tokenPtr = TokenAfter(tokenPtr); } } @@ -2001,7 +1999,7 @@ 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, @@ -2017,11 +2015,11 @@ TclCompileSwitchCmd( */ freeTemporaries: - Tcl_Free(bodyToken); - Tcl_Free(bodyLines); - Tcl_Free(bodyContLines); + TclStackFree(interp, bodyToken); + TclStackFree(interp, bodyLines); + TclStackFree(interp, bodyContLines); if (bodyTokenArray != NULL) { - Tcl_Free(bodyTokenArray); + TclStackFree(interp, bodyTokenArray); } return result; } @@ -2059,7 +2057,7 @@ IssueSwitchChainedTests( enum {Switch_Exact, Switch_Glob, Switch_Regexp}; int foundDefault; /* Flag to indicate whether a "default" clause * is present. */ - int *fwdJumps; /* Array of forward-jump fixup locations. */ + Tcl_BytecodeLabel *fwdJumps;/* Array of forward-jump fixup locations. */ int jumpCount; /* Number of places to fix up. */ int contJumpIdx; /* Where the first of the jumps due to a group * of continuation bodies starts, or -1 if @@ -2078,7 +2076,8 @@ IssueSwitchChainedTests( contJumpIdx = NO_PENDING_JUMP; contJumpCount = 0; - fwdJumps = (int *)TclStackAlloc(interp, sizeof(int) * numBodyTokens); + fwdJumps = (Tcl_BytecodeLabel *)TclStackAlloc(interp, + sizeof(Tcl_BytecodeLabel) * numBodyTokens); jumpCount = 0; foundDefault = 0; for (i=0 ; ihashTable, TCL_STRING_KEYS); infoIndex = TclCreateAuxData(jtPtr, &tclJumptableInfoType, envPtr); - finalFixups = (int *)TclStackAlloc(interp, sizeof(int) * (numBodyTokens/2)); + finalFixups = (Tcl_BytecodeLabel *)TclStackAlloc(interp, + sizeof(Tcl_BytecodeLabel) * (numBodyTokens/2)); foundDefault = 0; mustGenerate = 1; @@ -2312,7 +2313,7 @@ IssueSwitchJumpTable( * because that makes the code much easier to debug! */ - BACKLABEL(jumpLocation); + BACKLABEL( jumpLocation); OP4( JUMP_TABLE, infoIndex); FWDJUMP( JUMP, jumpToDefault); @@ -2396,12 +2397,6 @@ IssueSwitchJumpTable( */ if (i+2 < numBodyTokens || !foundDefault) { - /* - * 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. - */ - FWDJUMP( JUMP, finalFixups[numRealBodies++]); STKDELTA(-1); } @@ -2576,10 +2571,10 @@ TclCompileTailcallCmd( /* make room for the nsObjPtr */ /* TODO: Doesn't this have to be a known value? */ - CompileWord(envPtr, tokenPtr, interp, 0); + PUSH_TOKEN( tokenPtr, 0); for (i=1 ; i<(int)parsePtr->numWords ; i++) { tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, i); + PUSH_TOKEN( tokenPtr, i); } OP4( TAILCALL, (int)parsePtr->numWords); return TCL_OK; @@ -2634,10 +2629,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)); @@ -2648,7 +2643,7 @@ TclCompileThrowCmd( TclNewObj(dictPtr); TclDictPut(NULL, dictPtr, "-errorcode", objPtr); - TclEmitPush(TclAddLiteralObj(envPtr, dictPtr, NULL), envPtr); + PUSH_OBJ( dictPtr); } TclDecrRefCount(objPtr); @@ -2666,7 +2661,7 @@ TclCompileThrowCmd( } if (!codeKnown) { - int popForError; + Tcl_BytecodeLabel popForError; /* * Argument validity checking has to be done by bytecode at * run time. @@ -2679,7 +2674,7 @@ TclCompileThrowCmd( OP44( RETURN_IMM, TCL_ERROR, 0); STKDELTA(+2); - FWDLABEL( popForError); + FWDLABEL( popForError); OP( POP); OP( POP); OP( POP); @@ -2719,10 +2714,8 @@ TclCompileTryCmd( { int numWords = parsePtr->numWords, numHandlers, result = TCL_ERROR; 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; + int handlerIdx = 0; if (numWords < 2) { return TCL_ERROR; @@ -2736,7 +2729,7 @@ TclCompileTryCmd( */ DefineLineInformation; /* TIP #280 */ - BODY(bodyToken, 1); + BODY( bodyToken, 1); return TCL_OK; } @@ -2750,14 +2743,14 @@ 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 1) { + handlers = (TryHandlerInfo *)TclStackAlloc(interp, + sizeof(TryHandlerInfo) * numHandlers); + } else { + handlers = &staticHandler; + } + + for (; handlerIdx < numHandlers ; handlerIdx++) { Tcl_Obj *tmpObj, **objv; Tcl_Size objc; @@ -2770,18 +2763,18 @@ TclCompileTryCmd( * 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; + Tcl_IncrRefCount(tmpObj); + handlers[handlerIdx].matchClause = tmpObj; } else if (tokenPtr[1].size == 2 && !strncmp(tokenPtr[1].start, "on", 2)) { int code; @@ -2792,17 +2785,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; } @@ -2813,41 +2806,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 = -1; } 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 = -1; } - TclDecrRefCount(tmpObj); + Tcl_BounceRefCount(tmpObj); /* * Extract the body for this handler. @@ -2858,15 +2850,15 @@ TclCompileTryCmd( goto failedToCompile; } if (tokenPtr[1].size == 1 && tokenPtr[1].start[0] == '-') { - handlerTokens[i] = NULL; + 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; } } @@ -2896,15 +2888,13 @@ TclCompileTryCmd( if (!finallyToken) { result = IssueTryClausesInstructions(interp, envPtr, bodyToken, - numHandlers, matchCodes, matchClauses, resultVarIndices, - optionVarIndices, handlerTokens); + 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); + numHandlers, handlers, finallyToken); } /* @@ -2912,17 +2902,13 @@ TclCompileTryCmd( */ failedToCompile: - if (numHandlers > 0) { - for (i=0 ; i 0) { + 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; } @@ -2949,20 +2935,15 @@ IssueTryClausesInstructions( CompileEnv *envPtr, Tcl_Token *bodyToken, int numHandlers, - int *matchCodes, - Tcl_Obj **matchClauses, - int *resultVars, - int *optionVars, - Tcl_Token **handlerTokens) + TryHandlerInfo *handlers) { DefineLineInformation; /* TIP #280 */ - int range, resultVar, optionsVar; - int i, j, forwardsNeedFixing = 0, trapZero = 0, afterBody = 0; - int pushReturnOptions = 0; - Tcl_Size slen, len; - int *addrsToFix, *forwardsToFix, notCodeJumpSource, notECJumpSource; - int *noError; - char buf[TCL_INTEGER_SPACE]; + Tcl_LVTIndex resultVar, optionsVar; + int i, j, forwardsNeedFixing = 0, trapZero = 0; + Tcl_ExceptionRange range; + Tcl_BytecodeLabel afterBody = 0, pushReturnOptions = 0, *forwardsToFix; + Tcl_BytecodeLabel notCodeJumpSource, notECJumpSource, *addrsToFix, *noError; + Tcl_Size len; resultVar = AnonymousLocal(envPtr); optionsVar = AnonymousLocal(envPtr); @@ -2976,7 +2957,7 @@ IssueTryClausesInstructions( */ for (i=0 ; i 0) { FWDLABEL( pushReturnOptions); } OP( PUSH_RETURN_OPTIONS); @@ -3024,20 +3005,19 @@ 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); + addrsToFix = (Tcl_BytecodeLabel *)TclStackAlloc(interp, + sizeof(Tcl_BytecodeLabel) * numHandlers * 3); + forwardsToFix = addrsToFix + numHandlers; + noError = forwardsToFix + numHandlers; for (i=0 ; i= 0) { + if (handlers[i].resultVar >= 0) { OP4( LOAD_SCALAR, resultVar); - OP4( STORE_SCALAR, resultVars[i]); + OP4( STORE_SCALAR, handlers[i].resultVar); OP( POP); - if (optionVars[i] >= 0) { + if (handlers[i].optionVar >= 0) { OP4( LOAD_SCALAR, optionsVar); - OP4( STORE_SCALAR, optionVars[i]); + OP4( STORE_SCALAR, handlers[i].optionVar); OP( POP); } } - if (!handlerTokens[i]) { + if (!handlers[i].tokenPtr) { forwardsNeedFixing = 1; FWDJUMP( JUMP, forwardsToFix[i]); STKDELTA(+1); } else { - int dontChangeOptions; + Tcl_BytecodeLabel dontChangeOptions; forwardsToFix[i] = -1; if (forwardsNeedFixing) { @@ -3090,16 +3068,16 @@ IssueTryClausesInstructions( forwardsToFix[j] = -1; } } - range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); + range = MAKE_CATCH_RANGE(); OP4( BEGIN_CATCH, range); CATCH_RANGE(range) { - BODY( handlerTokens[i], 5+i*4); + BODY( handlers[i].tokenPtr, 5 + i*4); } OP( END_CATCH); FWDJUMP( JUMP, noError[i]); - ExceptionRangeTarget(envPtr, range, catchOffset); STKDELTA(-1); + CATCH_TARGET(range); OP( PUSH_RESULT); OP( PUSH_RETURN_OPTIONS); OP( PUSH_RETURN_CODE); @@ -3109,20 +3087,20 @@ IssueTryClausesInstructions( FWDJUMP( JUMP_FALSE, dontChangeOptions); OP4( LOAD_SCALAR, optionsVar); - OP4( REVERSE, 2); + OP( SWAP); OP4( STORE_SCALAR, optionsVar); OP( POP); PUSH( "-during"); - OP4( REVERSE, 2); + OP( SWAP); OP44( DICT_SET, 1, optionsVar); FWDLABEL( dontChangeOptions); - OP4( REVERSE, 2); + OP( SWAP); INVOKE( RETURN_STK); } FWDJUMP( JUMP, addrsToFix[i]); - if (matchClauses[i]) { + if (handlers[i].matchClause) { FWDLABEL( notECJumpSource); } FWDLABEL( notCodeJumpSource); @@ -3153,8 +3131,6 @@ IssueTryClausesInstructions( FWDLABEL( noError[i]); } } - TclStackFree(interp, noError); - TclStackFree(interp, forwardsToFix); TclStackFree(interp, addrsToFix); return TCL_OK; } @@ -3165,24 +3141,21 @@ IssueTryClausesFinallyInstructions( CompileEnv *envPtr, Tcl_Token *bodyToken, int numHandlers, - int *matchCodes, - Tcl_Obj **matchClauses, - int *resultVars, - int *optionVars, - Tcl_Token **handlerTokens, + TryHandlerInfo *handlers, Tcl_Token *finallyToken) /* Not NULL */ { DefineLineInformation; /* TIP #280 */ - int range, resultVar, optionsVar, i, j, forwardsNeedFixing = 0; - int trapZero = 0, afterBody = 0, finalOK, finalError, noFinalError; - int *addrsToFix, *forwardsToFix, notCodeJumpSource, notECJumpSource; - int pushReturnOptions = 0, endCatch = 0; - char buf[TCL_INTEGER_SPACE]; - Tcl_Size slen, len; + Tcl_LVTIndex resultLocal, optionsLocal; + int i, j, forwardsNeedFixing = 0, trapZero = 0; + Tcl_ExceptionRange range; + Tcl_BytecodeLabel *addrsToFix, *forwardsToFix; + Tcl_BytecodeLabel finalOK, finalError, noFinalError; + Tcl_BytecodeLabel pushReturnOptions = 0, endCatch = 0, afterBody = 0; + Tcl_Size len; - resultVar = AnonymousLocal(envPtr); - optionsVar = AnonymousLocal(envPtr); - if (resultVar < 0 || optionsVar < 0) { + resultLocal = AnonymousLocal(envPtr); + optionsLocal = AnonymousLocal(envPtr); + if (resultLocal < 0 || optionsLocal < 0) { return TCL_ERROR; } @@ -3192,7 +3165,7 @@ IssueTryClausesFinallyInstructions( */ for (i=0 ; i= 0 || handlerTokens[i]) { - range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); + if (handlers[i].resultVar >= 0 || handlers[i].tokenPtr) { + range = MAKE_CATCH_RANGE(); OP4( BEGIN_CATCH, range); ExceptionRangeStarts(envPtr, range); } - if (resultVars[i] >= 0) { - OP4( LOAD_SCALAR, resultVar); - OP4( STORE_SCALAR, resultVars[i]); + if (handlers[i].resultVar >= 0) { + OP4( LOAD_SCALAR, resultLocal); + OP4( STORE_SCALAR, handlers[i].resultVar); OP( POP); - if (optionVars[i] >= 0) { - OP4( LOAD_SCALAR, optionsVar); - OP4( STORE_SCALAR, optionVars[i]); + if (handlers[i].optionVar >= 0) { + 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 @@ -3311,7 +3280,7 @@ IssueTryClausesFinallyInstructions( 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. @@ -3329,7 +3298,7 @@ IssueTryClausesFinallyInstructions( */ if (forwardsNeedFixing) { - int bodyStart; + Tcl_BytecodeLabel bodyStart; forwardsNeedFixing = 0; FWDJUMP( JUMP, bodyStart); for (j=0 ; jatCmdStart &= ~1; - BACKLABEL( testCodeOffset); + CONTINUE_TARGET(range); } /* @@ -3803,30 +3778,26 @@ TclCompileWhileCmd( if (loopMayEnd) { FWDLABEL( jumpEvalCond); - BACKLABEL( testCodeOffset); - SetLineInformation(1); - TclCompileExprWords(interp, testTokenPtr, 1, envPtr); - + CONTINUE_TARGET(range); + PUSH_EXPR_TOKEN( testTokenPtr, 1); BACKJUMP( JUMP_TRUE, bodyCodeOffset); } else { 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; } @@ -3861,12 +3832,12 @@ 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); } INVOKE( YIELD); return TCL_OK; @@ -3908,7 +3879,7 @@ TclCompileYieldToCmd( OP( NS_CURRENT); for (i = 1 ; i < (int)parsePtr->numWords ; i++) { - CompileWord(envPtr, tokenPtr, interp, i); + PUSH_TOKEN( tokenPtr, i); tokenPtr = TokenAfter(tokenPtr); } OP4( LIST, i); @@ -3948,7 +3919,7 @@ CompileUnaryOpCmd( return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); + PUSH_TOKEN( tokenPtr, 1); TclEmitOpcode(instruction, envPtr); return TCL_OK; } @@ -3990,10 +3961,10 @@ CompileAssociativeBinaryOpCmd( /* TODO: Consider support for compiling expanded args. */ for (words=1 ; wordsnumWords ; 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) { @@ -4076,30 +4047,30 @@ CompileComparisonOpCmd( 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 (!EnvHasLVT(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); + PUSH_TOKEN( tokenPtr, 2); OP4( STORE_SCALAR, tmpIndex); TclEmitOpcode(instruction, envPtr); for (words=3 ; wordsnumWords ;) { OP4( LOAD_SCALAR, tmpIndex); tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, words); + PUSH_TOKEN( tokenPtr, words); if (++words < parsePtr->numWords) { OP4( STORE_SCALAR, tmpIndex); } @@ -4233,10 +4204,10 @@ TclCompilePowOpCmd( for (words=1 ; wordsnumWords ; 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) { @@ -4437,7 +4408,7 @@ TclCompileMinusOpCmd( } for (words=1 ; wordsnumWords ; words++) { tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, words); + PUSH_TOKEN( tokenPtr, words); } if (words == 2) { OP( UMINUS); @@ -4455,7 +4426,7 @@ TclCompileMinusOpCmd( OP4( REVERSE, words - 1); while (--words > 1) { - OP4( REVERSE, 2); + OP( SWAP); OP( SUB); } return TCL_OK; @@ -4481,11 +4452,11 @@ TclCompileDivOpCmd( return TCL_ERROR; } if (parsePtr->numWords == 2) { - PUSH("1.0"); + PUSH( "1.0"); } for (words=1 ; wordsnumWords ; words++) { tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, words); + PUSH_TOKEN( tokenPtr, words); } if (words <= 3) { OP( DIV); @@ -4499,7 +4470,7 @@ TclCompileDivOpCmd( OP4( REVERSE, words - 1); while (--words > 1) { - OP4( REVERSE, 2); + OP( SWAP); OP( DIV); } return TCL_OK; diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index a39ab07..d7b0648 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -2334,14 +2334,11 @@ CompileExprTree( switch (nodePtr->lexeme) { case FUNCTION: { Tcl_DString cmdName; - const char *p; - Tcl_Size length; Tcl_DStringInit(&cmdName); TclDStringAppendLiteral(&cmdName, "tcl::mathfunc::"); - p = TclGetStringFromObj(*funcObjv, &length); + TclDStringAppendObj(&cmdName, *funcObjv); funcObjv++; - Tcl_DStringAppend(&cmdName, p, length); TclEmitPush(TclRegisterLiteral(envPtr, Tcl_DStringValue(&cmdName), Tcl_DStringLength(&cmdName), LITERAL_CMD_NAME), envPtr); diff --git a/generic/tclCompUtils.h b/generic/tclCompUtils.h index 08cc349..2846fc2 100644 --- a/generic/tclCompUtils.h +++ b/generic/tclCompUtils.h @@ -15,6 +15,26 @@ #include "tclCompile.h" /* + * The type of "labels" used in FWDLABEL() and BACKLABEL(). + */ +typedef int Tcl_BytecodeLabel; + +/* + * The type of "catch ranges" used in CATCH_RANGE(), etc. + */ +typedef int Tcl_ExceptionRange; + +/* + * The type of indices into the local variable table. + */ +typedef int Tcl_LVTIndex; + +/* + * The type of handles made by TclCreateAuxData() + */ +typedef int Tcl_AuxDataRef; + +/* * Shorthand macros for instruction issuing. */ @@ -31,6 +51,20 @@ #define PUSH(str) \ PushStringLiteral(envPtr, str) +#define PUSH_STRING(strVar) \ + PushLiteral(envPtr, (strVar), TCL_AUTO_LENGTH) +#define PUSH_SIMPLE_TOKEN(tokenPtr) \ + PushLiteral(envPtr, (tokenPtr)[1].start, (tokenPtr)[1].size) +#define PUSH_OBJ(objPtr) \ + TclEmitPush(TclAddLiteralObj(envPtr, (objPtr), NULL), envPtr) +#define PUSH_TOKEN(tokenPtr, index) \ + CompileWord(envPtr, (tokenPtr), interp, (index)) +#define PUSH_EXPR_TOKEN(tokenPtr, index) \ + do { \ + SetLineInformation(index); \ + TclCompileExprWords(interp, (tokenPtr), 1, envPtr); \ + } while (0) + #define BACKLABEL(var) \ (var)=CurrentOffset(envPtr) #define BACKJUMP(name, var) \ @@ -42,10 +76,26 @@ #define INVOKE(name) \ TclEmitInvoke(envPtr,INST_##name) +#define MAKE_CATCH_RANGE() \ + TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr) +#define MAKE_LOOP_RANGE() \ + TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr) +#define CATCH_RANGE0(range,var) \ + for(int var=(ExceptionRangeStarts(envPtr,(range)), 0); \ + !var; \ + var=(ExceptionRangeEnds(envPtr,(range)), 1)) +#define CATCH_RANGE_VAR0(x, y) x ## y +#define CATCH_RANGE_VAR(line) CATCH_RANGE_VAR0(catchRange_, line) #define CATCH_RANGE(range) \ - for(int tcl__range=(ExceptionRangeStarts(envPtr,(range)),0); \ - !tcl__range; \ - tcl__range=(ExceptionRangeEnds(envPtr,(range)),1)) + CATCH_RANGE0((range), CATCH_RANGE_VAR(__LINE__)) +#define CATCH_TARGET(range) \ + ExceptionRangeTarget(envPtr, (range), catchOffset) +#define BREAK_TARGET(range) \ + ExceptionRangeTarget(envPtr, (range), breakOffset) +#define CONTINUE_TARGET(range) \ + ExceptionRangeTarget(envPtr, (range), continueOffset) +#define FINALIZE_LOOP(range) \ + TclFinalizeLoopExceptionRange(envPtr, (range)) #define STKDELTA(delta) \ TclAdjustStackDepth((delta), envPtr) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index fc4bae0..8423557 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -27,11 +27,30 @@ */ #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,size,stack) \ + {name,size,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}} + +#define DEPRECATED_INSTRUCTION_ENTRY(name,size,stack) \ + {name,size,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 @@ -44,216 +63,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, -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] */ - {"push", 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, -1), /* Pop the topmost stack object */ - {"dup", 1, +1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "dup", 1, +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]; = */ - {"invokeStk", 5, INT_MIN, 1, {OPERAND_UINT4}}, + TCL_INSTRUCTION_ENTRY1( + "invokeStk", 5, INT_MIN, OPERAND_UINT4), /* Invoke command named objv[0]; = */ - {"evalStk", 1, 0, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "evalStk", 1, 0), /* Evaluate command in stktop using Tcl_EvalObj. */ - {"exprStk", 1, 0, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "exprStk", 1, 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 */ - {"loadScalar", 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", 1, 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 */ - {"loadArray", 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, -1), /* Load array element; element is stktop, array name is stknext */ - {"loadStk", 1, 0, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "loadStk", 1, 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 */ - {"storeScalar", 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, -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 */ - {"storeArray", 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", 1, -2), /* Store array element; value is stktop, then elem, array names */ - {"storeStk", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "storeStk", 1, -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, -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", 1, -2), /* Incr array element; amount is top then elem then array names */ - {"incrStk", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "incrStk", 1, -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) */ - {"jump", 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 */ - {"jumpTrue", 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 */ - {"jumpFalse", 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, -1), /* Bitwise or: push (stknext | stktop) */ - {"bitxor", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "bitxor", 1, -1), /* Bitwise xor push (stknext ^ stktop) */ - {"bitand", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "bitand", 1, -1), /* Bitwise and: push (stknext & stktop) */ - {"eq", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "eq", 1, -1), /* Equal: push (stknext == stktop) */ - {"neq", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "neq", 1, -1), /* Not equal: push (stknext != stktop) */ - {"lt", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "lt", 1, -1), /* Less: push (stknext < stktop) */ - {"gt", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "gt", 1, -1), /* Greater: push (stknext > stktop) */ - {"le", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "le", 1, -1), /* Less or equal: push (stknext <= stktop) */ - {"ge", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "ge", 1, -1), /* Greater or equal: push (stknext >= stktop) */ - {"lshift", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "lshift", 1, -1), /* Left shift: push (stknext << stktop) */ - {"rshift", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "rshift", 1, -1), /* Right shift: push (stknext >> stktop) */ - {"add", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "add", 1, -1), /* Add: push (stknext + stktop) */ - {"sub", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "sub", 1, -1), /* Sub: push (stkext - stktop) */ - {"mult", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "mult", 1, -1), /* Multiply: push (stknext * stktop) */ - {"div", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "div", 1, -1), /* Divide: push (stknext / stktop) */ - {"mod", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "mod", 1, -1), /* Mod: push (stknext % stktop) */ - {"uplus", 1, 0, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "uplus", 1, 0), /* Unary plus: push +stktop */ - {"uminus", 1, 0, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "uminus", 1, 0), /* Unary minus: push -stktop */ - {"bitnot", 1, 0, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "bitnot", 1, 0), /* Bitwise not: push ~stktop */ - {"not", 1, 0, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "not", 1, 0), /* Logical not: push !stktop */ - {"tryCvtToNumeric", 1, 0, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "tryCvtToNumeric",1, 0), /* Try converting stktop to first int then double if possible. */ - {"break", 1, 0, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "break", 1, 0), /* Abort closest enclosing loop; if none, return TCL_BREAK code. */ - {"continue", 1, 0, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "continue", 1, 0), /* Skip to next iteration of closest enclosing loop; if none, return * TCL_CONTINUE code. */ - {"beginCatch", 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", 1, 0), /* End of last catch. Pop the bytecode interpreter's catch stack. */ - {"pushResult", 1, +1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "pushResult", 1, +1), /* Push the interpreter's object result onto the stack. */ - {"pushReturnCode", 1, +1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "pushReturnCode", 1, +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, -1), /* Str Equal: push (stknext eq stktop) */ - {"strneq", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "strneq", 1, -1), /* Str !Equal: push (stknext neq stktop) */ - {"strcmp", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "strcmp", 1, -1), /* Str Compare: push (stknext cmp stktop) */ - {"strlen", 1, 0, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "strlen", 1, 0), /* Str Length: push (strlen stktop) */ - {"strindex", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "strindex", 1, -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, -1), /* List Index: push (listindex stknext stktop) */ - {"listLength", 1, 0, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "listLength", 1, 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 */ - {"appendScalar", 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 */ - {"appendArray", 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", 1, -2), /* Append array element; value is stktop, then elem, array names */ - {"appendStk", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "appendStk", 1, -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 */ - {"lappendScalar", 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 */ - {"lappendArray", 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",1, -2), /* Lappend array element; value is stktop, then elem, array names */ - {"lappendStk", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "lappendStk", 1, -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", 1, -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, -1), /* Binary exponentiation operator: push (stknext ** stktop) */ /* @@ -264,264 +376,329 @@ 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", 1, 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", 1, 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}}, + TCL_INSTRUCTION_ENTRY( + "listIn", 1, -1), /* List containment: push [lsearch stktop stknext]>=0) */ - {"listNotIn", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "listNotIn", 1, -1), /* List negated containment: push [lsearch stktop stknext]<0) */ - {"pushReturnOpts", 1, +1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "pushReturnOpts", 1, +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, -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. * 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, -1), /* Test if array element exists; element is stktop, array name is * stknext */ - {"existStk", 1, 0, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "existStk", 1, 0), /* Test if general variable exists; unparsed variable name is stktop*/ - {"nop", 1, 0, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "nop", 1, 0), /* Do nothing */ - {"returnCodeBranch1", 1, -1, 0, {OPERAND_NONE}}, + DEPRECATED_INSTRUCTION_ENTRY( + "returnCodeBranch1", 1,-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_UNSF1, 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_UNSF1, 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_UNSF1}}, + 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_UNSF1}}, + 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, -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", 1, -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, -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", 1, -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, -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, -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", 1, -2), /* String Range with non-constant arguments. * Stack: ... string idxA idxB => ... substring */ - {"yield", 1, 0, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "yield", 1, 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, +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, +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, +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", 1, 0), /* Push the argument words to a stack depth (i.e., [info level ]) * of the interpreter as an object on the stack. * Stack: ... depth => ... argList */ - {"resolveCmd", 1, 0, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "resolveCmd", 1, 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, +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", 1, 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",1, 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", 1, 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",1, 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, -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 op1 words at the top of the stack; * = */ - {"listConcat", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "listConcat", 1, -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", 1, 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 @@ -531,73 +708,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", 1, 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", 1, 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, -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, -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, -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, -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", 1, 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", 1, 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", 1, 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", 1, -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", 1, 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 @@ -605,44 +796,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", 1, 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", 1, 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, +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", 1, -2), /* Lappend list to array element. * Stack: ... arrayName elem list => ... listVarContents */ - {"lappendListStk", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "lappendListStk", 1, -1), /* Lappend list to general variable. * Stack: ... varName list => ... listVarContents */ - {"clockRead", 2, +1, 1, {OPERAND_CLK1}}, + 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 @@ -650,54 +851,67 @@ InstructionDesc const tclInstructionTable[] = { * default is pushed instead. * Stack: ... dict key1 ... keyN default => ... value */ - {"strlt", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "strlt", 1, -1), /* String Less: push (stknext < stktop) */ - {"strgt", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "strgt", 1, -1), /* String Greater: push (stknext > stktop) */ - {"strle", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "strle", 1, -1), /* String Less or equal: push (stknext <= stktop) */ - {"strge", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "strge", 1, -1), /* String Greater or equal: push (stknext >= stktop) */ - {"lreplace", 6, INT_MIN, 2, {OPERAND_UINT4, OPERAND_LRPL1}}, + TCL_INSTRUCTION_ENTRY2( + "lreplace", 6, INT_MIN, OPERAND_UINT4, OPERAND_LRPL1), /* Operands: number of arguments, flags * flags: Combination of TCL_LREPLACE4_* 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", 1, -2), /* Create constant. Variable name and value on stack. * Stack: ... varName value => ... */ - {"returnCodeBranch", 1, -1, 0, {OPERAND_NONE}}, + TCL_INSTRUCTION_ENTRY( + "returnCodeBranch", 1, -1), /* Jump to next instruction based on the return code on top of stack * ERROR: +1; RETURN: +6; BREAK: +11; CONTINUE: +16; - * Other non-OK: +21 - */ - {"incrScalar", 5, 0, 1, {OPERAND_LVT4}}, + * Other non-OK: +21 */ + TCL_INSTRUCTION_ENTRY1( + "incrScalar", 5, 0, OPERAND_LVT4), /* Incr scalar at index op1 in frame; incr amount is stktop */ - {"incrArray", 5, -1, 1, {OPERAND_LVT4}}, + TCL_INSTRUCTION_ENTRY1( + "incrArray", 5, -1, OPERAND_LVT4), /* Incr array elem; arr at slot op1, amount is top then elem */ - {"incrScalarImm", 6, +1, 2, {OPERAND_LVT4, OPERAND_INT1}}, + TCL_INSTRUCTION_ENTRY2( + "incrScalarImm", 6, +1, OPERAND_LVT4, OPERAND_INT1), /* Incr scalar at slot op1; amount is 2nd operand byte */ - {"incrArrayImm", 6, 0, 2, {OPERAND_LVT4, OPERAND_INT1}}, + 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 */ - {"tailcall", 5, INT_MIN, 1, {OPERAND_UINT4}}, + 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. */ - {"tclooNext", 5, INT_MIN, 1, {OPERAND_UINT4}}, + 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 */ - {"tclooNextClass", 5, INT_MIN, 1, {OPERAND_UINT4}}, + 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 @@ -705,7 +919,18 @@ InstructionDesc const tclInstructionTable[] = { * arguments (similar to invokeStk). * Stack: ... "nextto" className arg3 arg4 -- argN => ... result */ - {NULL, 0, 0, 0, {OPERAND_NONE}} + TCL_INSTRUCTION_ENTRY( + "swap", 1, 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 */ + + {NULL, 0, 0, 0, {OPERAND_NONE}} }; /* @@ -2037,12 +2262,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; } /* @@ -2050,8 +2290,7 @@ CompileCmdCompileProc( * partial compiles. */ - envPtr->numCommands = mapPtr->nuloc; - return TCL_ERROR; + envPtr->numCommands = lineInfoPtr->mapPtr->nuloc; } static int @@ -2254,7 +2493,8 @@ TclCompileScript( * TODO: Suppress when numWords == 0 ? */ - if ((tclTraceCompile >= 1) && (envPtr->procPtr == NULL)) { + if ((tclTraceCompile >= TCL_TRACE_BYTECODE_COMPILE_SUMMARY) + && (envPtr->procPtr == NULL)) { int commandLength = parsePtr->term - parsePtr->commandStart; fprintf(stdout, " Compiling: "); TclPrintSource(stdout, parsePtr->commandStart, @@ -2294,7 +2534,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; @@ -2961,7 +3201,8 @@ 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 @@ -3262,7 +3503,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"); } } @@ -3426,7 +3667,7 @@ EnterCmdWordData( Tcl_Size 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; @@ -4081,12 +4322,14 @@ 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; +#endif case INST_TCLOO_NEXT: case INST_TCLOO_NEXT_CLASS: case INST_INVOKE_STK: @@ -4160,9 +4403,11 @@ TclEmitInvoke( */ switch (opcode) { +#ifndef TCL_NO_DEPRECATED case INST_INVOKE_STK1: TclEmitInstInt1( INST_INVOKE_STK1, arg1, envPtr); break; +#endif case INST_INVOKE_STK: TclEmitInstInt4( INST_INVOKE_STK, arg1, envPtr); break; @@ -4179,14 +4424,15 @@ TclEmitInvoke( break; case INST_INVOKE_REPLACE: TclEmitInstInt41( INST_INVOKE_REPLACE, arg1, arg2, envPtr); - TclAdjustStackDepth(-1, envPtr); /* Correction to stack depth calcs */ break; +#ifndef TCL_NO_DEPRECATED case INST_TCLOO_NEXT1: TclEmitInstInt1( INST_TCLOO_NEXT1, arg1, envPtr); break; case INST_TCLOO_NEXT_CLASS1: TclEmitInstInt1( INST_TCLOO_NEXT_CLASS1, arg1, envPtr); break; +#endif case INST_TCLOO_NEXT: TclEmitInstInt4( INST_TCLOO_NEXT, arg1, envPtr); break; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 52da7c7..e8db39f 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -36,6 +36,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 +53,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 /* @@ -390,6 +403,12 @@ typedef struct CompileEnv { * continuation line. */ } CompileEnv; +typedef struct LineInformation { + ExtCmdLoc *mapPtr; /* Extended command location information for + * 'info frame'. */ + Tcl_Size eclIndex; /* Current index into mapPtr->loc. */ +} LineInformation; + /* * The structure defining the bytecode instructions resulting from compiling a * Tcl script. Note that this structure is variable length: a single heap @@ -398,21 +417,26 @@ typedef struct CompileEnv { * CmdLocation map, and the compilation AuxData array. */ -/* - * A PRECOMPILED bytecode struct is one that was generated from a compiled - * image rather than implicitly compiled from source - */ - -#define TCL_BYTECODE_PRECOMPILED 0x0001 - -/* - * When a bytecode is compiled, interp or namespace resolvers have not been - * applied yet: this is indicated by the TCL_BYTECODE_RESOLVE_VARS flag. - */ +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_RESOLVE_VARS 0x0002 + /* + * 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, -#define TCL_BYTECODE_RECOMPILE 0x0004 + /* + * 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 @@ -533,6 +557,14 @@ typedef struct ByteCode { (codePtr) = irPtr ? (ByteCode*)irPtr->twoPtrValue.ptr1 : NULL; \ } 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. + */ + #ifdef ALLOW_DEPRECATED_OPCODES #define DEPRECATED_OPCODE(name) \ name @@ -856,6 +888,9 @@ enum TclInstruction { INST_TCLOO_NEXT, INST_TCLOO_NEXT_CLASS, + INST_SWAP, + INST_ERROR_PREFIX_EQ, + /* The last opcode */ LAST_INST_OPCODE }; @@ -1050,7 +1085,7 @@ typedef struct JumptableInfo { MODULE_SCOPE const AuxDataType tclJumptableInfoType; #define JUMPTABLEINFO(envPtr, index) \ - ((JumptableInfo*)((envPtr)->auxDataArrayPtr[TclGetUInt4AtPtr(index)].clientData)) + ((JumptableInfo *) TclFetchAuxData((envPtr), TclGetUInt4AtPtr(index))) /* * Structure used to hold information about a [dict update] command that is @@ -1111,6 +1146,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); @@ -1243,9 +1280,11 @@ MODULE_SCOPE int TclPushProcCallFrame(void *clientData, #define TclFetchAuxData(envPtr, index) \ (envPtr)->auxDataArrayPtr[(index)].clientData -#define LITERAL_ON_HEAP 0x01 -#define LITERAL_CMD_NAME 0x02 -#define LITERAL_UNSHARED 0x04 +enum LiteralFlags { + LITERAL_ON_HEAP = 0x01, + LITERAL_CMD_NAME = 0x02, + LITERAL_UNSHARED = 0x04 +}; /* * Adjust the stack requirements. Manually used in cases where the stack @@ -1310,179 +1349,245 @@ TclUpdateStackReqs( } /* - * 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 { \ - unsigned tcl_i = (unsigned) (i); \ - if ((envPtr)->codeNext == (envPtr)->codeEnd) { \ - TclExpandCodeArray(envPtr); \ - } \ - *(envPtr)->codeNext++ = (unsigned char) tcl_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 { \ - unsigned tcl_i = (unsigned) (i); \ - if (((envPtr)->codeNext + 4) > (envPtr)->codeEnd) { \ - TclExpandCodeArray(envPtr); \ - } \ - *(envPtr)->codeNext++ = (unsigned char) (tcl_i >> 24); \ - *(envPtr)->codeNext++ = (unsigned char) (tcl_i >> 16); \ - *(envPtr)->codeNext++ = (unsigned char) (tcl_i >> 8); \ - *(envPtr)->codeNext++ = (unsigned char) (tcl_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); + TclUpdateStackReqs(op, i, envPtr); +} #define TclEmitInstInt1(op, i, envPtr) \ - do { \ - unsigned tcl_i = (unsigned) (i); \ - if (((envPtr)->codeNext + 2) > (envPtr)->codeEnd) { \ - TclExpandCodeArray(envPtr); \ - } \ - *(envPtr)->codeNext++ = (unsigned char) (op); \ - *(envPtr)->codeNext++ = (unsigned char) tcl_i; \ - TclUpdateAtCmdStart(op, envPtr); \ - TclUpdateStackReqs(op, tcl_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); + *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); + + /* Apply stack depth corrections. */ + switch(op) { + case INST_DICT_GET: + case INST_DICT_EXISTS: + TclAdjustStackDepth(-1, envPtr); + break; + case INST_DICT_GET_DEF: + TclAdjustStackDepth(-2, envPtr); + break; + default: + /* Do nothing special */ + break; + } +} #define TclEmitInstInt4(op, i, envPtr) \ - do { \ - unsigned tcl_i = (unsigned) (i); \ - if (((envPtr)->codeNext + 5) > (envPtr)->codeEnd) { \ - TclExpandCodeArray(envPtr); \ - } \ - *(envPtr)->codeNext++ = (unsigned char) (op); \ - *(envPtr)->codeNext++ = (unsigned char) (tcl_i >> 24); \ - *(envPtr)->codeNext++ = (unsigned char) (tcl_i >> 16); \ - *(envPtr)->codeNext++ = (unsigned char) (tcl_i >> 8); \ - *(envPtr)->codeNext++ = (unsigned char) (tcl_i ); \ - TclUpdateAtCmdStart(op, envPtr); \ - TclUpdateStackReqs(op, tcl_i, envPtr); \ - /* Apply stack depth corrections. */ \ - switch(op) { \ - case INST_DICT_GET: case INST_DICT_EXISTS: \ - TclAdjustStackDepth(-1, envPtr); break; \ - case INST_DICT_GET_DEF: \ - TclAdjustStackDepth(-2, envPtr); break; \ - default: /* Do nothing special*/ break; \ - } \ - } while (0) + TclEmitInstInt4Impl((op), (unsigned)(i), (envPtr)) +static inline void +TclEmitInstInt14Impl( + unsigned char op, + unsigned i, + unsigned j, + CompileEnv *envPtr) +{ + if (envPtr->codeNext + 6 > envPtr->codeEnd) { + TclExpandCodeArray(envPtr); + } + + *envPtr->codeNext++ = UCHAR(op); + *envPtr->codeNext++ = UCHAR(i ); + *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); +} #define TclEmitInstInt14(op, i, j, envPtr) \ - do { \ - unsigned tcl_i = (unsigned) (i), tcl_j = (unsigned) (j); \ - if (((envPtr)->codeNext + 6) > (envPtr)->codeEnd) { \ - TclExpandCodeArray(envPtr); \ - } \ - *(envPtr)->codeNext++ = (unsigned char) (op); \ - *(envPtr)->codeNext++ = (unsigned char) tcl_i; \ - *(envPtr)->codeNext++ = (unsigned char) (tcl_j >> 24); \ - *(envPtr)->codeNext++ = (unsigned char) (tcl_j >> 16); \ - *(envPtr)->codeNext++ = (unsigned char) (tcl_j >> 8); \ - *(envPtr)->codeNext++ = (unsigned char) (tcl_j ); \ - TclUpdateAtCmdStart(op, envPtr); \ - TclUpdateStackReqs(op, tcl_i, envPtr); \ - } while (0) + TclEmitInstInt14Impl((op), (unsigned)(i), (unsigned)(j), (envPtr)) +static inline void +TclEmitInstInt41Impl( + unsigned char op, + unsigned i, + unsigned j, + CompileEnv *envPtr) +{ + if (envPtr->codeNext + 6 > envPtr->codeEnd) { + TclExpandCodeArray(envPtr); + } + + *envPtr->codeNext++ = UCHAR(op); + *envPtr->codeNext++ = UCHAR(i >> 24); + *envPtr->codeNext++ = UCHAR(i >> 16); + *envPtr->codeNext++ = UCHAR(i >> 8); + *envPtr->codeNext++ = UCHAR(i ); + *envPtr->codeNext++ = UCHAR(j ); + + TclUpdateAtCmdStart(op, envPtr); + TclUpdateStackReqs(op, i, envPtr); + + /* Apply stack depth corrections. */ + switch(op) { + case INST_INVOKE_REPLACE: + TclAdjustStackDepth(-1, envPtr); + break; + default: + /* Do nothing special */ + break; + } +} #define TclEmitInstInt41(op, i, j, envPtr) \ - do { \ - unsigned tcl_i = (unsigned) (i), tcl_j = (unsigned) (j); \ - if (((envPtr)->codeNext + 6) > (envPtr)->codeEnd) { \ - TclExpandCodeArray(envPtr); \ - } \ - *(envPtr)->codeNext++ = (unsigned char) (op); \ - *(envPtr)->codeNext++ = (unsigned char) (tcl_i >> 24); \ - *(envPtr)->codeNext++ = (unsigned char) (tcl_i >> 16); \ - *(envPtr)->codeNext++ = (unsigned char) (tcl_i >> 8); \ - *(envPtr)->codeNext++ = (unsigned char) (tcl_i ); \ - *(envPtr)->codeNext++ = (unsigned char) (tcl_j ); \ - TclUpdateAtCmdStart(op, envPtr); \ - TclUpdateStackReqs(op, tcl_i, envPtr); \ - } while (0) + TclEmitInstInt41Impl((op), (unsigned)(i), (unsigned)(j), (envPtr)) +static inline void +TclEmitInstInt44Impl( + unsigned char op, + unsigned i, + unsigned j, + CompileEnv *envPtr) +{ + if (envPtr->codeNext + 9 > envPtr->codeEnd) { + TclExpandCodeArray(envPtr); + } + + *envPtr->codeNext++ = UCHAR(op); + *envPtr->codeNext++ = UCHAR(i >> 24); + *envPtr->codeNext++ = UCHAR(i >> 16); + *envPtr->codeNext++ = UCHAR(i >> 8); + *envPtr->codeNext++ = UCHAR(i ); + *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); + + /* Apply stack depth corrections. */ + switch(op) { + case INST_DICT_SET: + TclAdjustStackDepth(-1, envPtr); + break; + default: + /* Do nothing special */ + break; + } +} #define TclEmitInstInt44(op, i, j, envPtr) \ - do { \ - unsigned tcl_i = (unsigned) (i), tcl_j = (unsigned) (j); \ - if (((envPtr)->codeNext + 9) > (envPtr)->codeEnd) { \ - TclExpandCodeArray(envPtr); \ - } \ - *(envPtr)->codeNext++ = (unsigned char) (op); \ - *(envPtr)->codeNext++ = (unsigned char) (tcl_i >> 24); \ - *(envPtr)->codeNext++ = (unsigned char) (tcl_i >> 16); \ - *(envPtr)->codeNext++ = (unsigned char) (tcl_i >> 8); \ - *(envPtr)->codeNext++ = (unsigned char) (tcl_i ); \ - *(envPtr)->codeNext++ = (unsigned char) (tcl_j >> 24); \ - *(envPtr)->codeNext++ = (unsigned char) (tcl_j >> 16); \ - *(envPtr)->codeNext++ = (unsigned char) (tcl_j >> 8); \ - *(envPtr)->codeNext++ = (unsigned char) (tcl_j ); \ - TclUpdateAtCmdStart(op, envPtr); \ - TclUpdateStackReqs(op, tcl_i, envPtr); \ - /* Apply stack depth corrections. */ \ - switch(op) { \ - case INST_DICT_SET: \ - TclAdjustStackDepth(-1, envPtr); break; \ - default: /* Do nothing special*/ break; \ - } \ - } while (0) + TclEmitInstInt44Impl((op), (unsigned)(i), (unsigned)(j), (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); \ - TclEmitInstInt4(INST_PUSH, _objIndexCopy, (envPtr)); \ - } while (0) +static inline void +TclEmitPush( + int objIndex, + CompileEnv *envPtr) +{ + TclEmitInstInt4(INST_PUSH, objIndex, envPtr); +} /* * Macros to update a (signed or unsigned) integer starting at a pointer. The @@ -1493,16 +1598,28 @@ TclUpdateStackReqs( * void TclStoreInt4AtPtr(int i, unsigned char *p); */ +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 @@ -1526,16 +1643,28 @@ TclUpdateStackReqs( } 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: + * Macro to get the offset to the next instruction to be issued. The ANSI C + * "prototype" for this macro is: * - * int TclFixupForwardJumpToHere(CompileEnv *envPtr, JumpFixup *fixupPtr); + * static ptrdiff_t CurrentOffset(CompileEnv *envPtr); + */ + +#define CurrentOffset(envPtr) \ + ((envPtr)->codeNext - (envPtr)->codeStart) + +/* + * 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) \ - TclFixupForwardJump((envPtr), (fixupPtr), \ - (envPtr)->codeNext-(envPtr)->codeStart-(int)(fixupPtr)->codeOffset) +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 @@ -1550,35 +1679,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 +} -#define TclGetInt4AtPtr(p) \ - ((int) ((TclGetUInt1AtPtr(p) << 24) | \ - (*((p)+1) << 16) | \ - (*((p)+2) << 8) | \ - (*((p)+3)))) +static inline unsigned int +TclGetUInt1AtPtr( + const unsigned char *p) +{ + return (unsigned) *p; +} + +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 @@ -1588,8 +1734,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)) +#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 @@ -1614,6 +1760,7 @@ 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: @@ -1640,16 +1787,6 @@ TclUpdateStackReqs( ((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) - -/* * Note: the exceptDepth is a bit of a misnomer: TEBC only needs the * maximal depth of nested CATCH ranges in order to alloc runtime * memory. These macros should compute precisely that? OTOH, the nesting depth @@ -1661,15 +1798,30 @@ TclUpdateStackReqs( * 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 int +ExceptionRangeStarts( + CompileEnv *envPtr, + Tcl_Size index) +{ + Tcl_Size offset; + + envPtr->exceptDepth++; + envPtr->maxExceptDepth = TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth); + offset = CurrentOffset(envPtr); + envPtr->exceptArrayPtr[index].codeOffset = offset; + return (int) offset; +} + +static inline void +ExceptionRangeEnds( + CompileEnv *envPtr, + Tcl_Size index) +{ + envPtr->exceptDepth--; + envPtr->exceptArrayPtr[index].numCodeBytes = + CurrentOffset(envPtr) - envPtr->exceptArrayPtr[index].codeOffset; +} + #define ExceptionRangeTarget(envPtr, index, targetType) \ ((envPtr)->exceptArrayPtr[(index)].targetType = CurrentOffset(envPtr)) @@ -1714,21 +1866,32 @@ 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 ExtCmdLocation \ + lineInfo.mapPtr->loc[lineInfo.eclIndex] #define SetLineInformation(word) \ - envPtr->line = mapPtr->loc[eclIndex].line[(word)]; \ - envPtr->clNext = mapPtr->loc[eclIndex].next[(word)] + do { \ + ECL *eclPtr = &ExtCmdLocation; \ + envPtr->line = eclPtr->line[(word)]; \ + envPtr->clNext = eclPtr->next[(word)]; \ + } while (0) #define PushVarNameWord(i,v,e,f,l,sc,word) \ SetLineInformation(word); \ TclPushVarName(i,v,e,f,l,sc) +#define ClearFailedCompile(envPtr) \ + TclClearFailedCompile((envPtr), &lineInfo) + /* * How to get an anonymous local variable (used for holding temporary values * off the stack) or a local simple scalar. @@ -1747,15 +1910,18 @@ TclUpdateStackReqs( * 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_LREPLACE4_END_IS_LAST = 1, /* "end" refers to last element */ + TCL_LREPLACE4_SINGLE_INDEX = 2 /* Second index absent (pure insert) */ +}; /* * DTrace probe macros (NOPs if DTrace support is not enabled). diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index a95dcb1..60917f2 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -133,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)); diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index a11f382..eb186fc 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -11,7 +11,7 @@ */ #include "tclInt.h" -#include "tclCompile.h" +#include "tclCompUtils.h" /* * Declarations for functions local to this file: @@ -3254,18 +3254,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 @@ -3325,7 +3314,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 @@ -3353,8 +3342,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! @@ -3366,8 +3355,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; @@ -3471,8 +3460,7 @@ 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; } diff --git a/generic/tclExecute.c b/generic/tclExecute.c index adb0318..c433d4d 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -65,7 +65,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 /* @@ -237,6 +237,20 @@ VarHashCreateVar( } \ } 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_Panic("should be unreachable"); \ + } \ + } while (0) + #define NEXT_INST_V(pcAdjustment, nCleanup, resultHandling) \ CHECK_STACK(); \ do { \ @@ -258,16 +272,16 @@ VarHashCreateVar( pc += (pcAdjustment); \ switch (*pc) { \ case INST_JUMP_FALSE1: \ - NEXT_INST_F(((condition)? 2 : TclGetInt1AtPtr(pc+1)), (cleanup), 0); \ + NEXT_INST_F0(((condition)? 2 : TclGetInt1AtPtr(pc+1)), (cleanup)); \ break; \ case INST_JUMP_TRUE1: \ - NEXT_INST_F(((condition)? TclGetInt1AtPtr(pc+1) : 2), (cleanup), 0); \ + NEXT_INST_F0(((condition)? TclGetInt1AtPtr(pc+1) : 2), (cleanup)); \ break; \ case INST_JUMP_FALSE: \ - NEXT_INST_F(((condition)? 5 : TclGetInt4AtPtr(pc+1)), (cleanup), 0); \ + NEXT_INST_F0(((condition)? 5 : TclGetInt4AtPtr(pc+1)), (cleanup)); \ break; \ case INST_JUMP_TRUE: \ - NEXT_INST_F(((condition)? TclGetInt4AtPtr(pc+1) : 5), (cleanup), 0); \ + NEXT_INST_F0(((condition)? TclGetInt4AtPtr(pc+1) : 5), (cleanup)); \ break; \ default: \ if ((condition) < 0) { \ @@ -2061,13 +2075,13 @@ TEBCresume( #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_T_MODIFIER "d\n", CURR_DEPTH); fflush(stdout); @@ -2329,7 +2343,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) { @@ -2349,7 +2363,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 @@ -2389,7 +2403,7 @@ TEBCresume( } #ifdef TCL_COMPILE_DEBUG - if (tclTraceExec >= 2) { + if (tclTraceExec >= TCL_TRACE_BYTECODE_EXEC_COMMANDS) { if (traceInstructions) { TRACE_APPEND(("YIELD...\n")); } else { @@ -2431,7 +2445,7 @@ TEBCresume( } #ifdef TCL_COMPILE_DEBUG - if (tclTraceExec >= 2) { + if (tclTraceExec >= TCL_TRACE_BYTECODE_EXEC_COMMANDS) { if (traceInstructions) { TRACE(("[%.30s] => YIELD...\n", O2S(valuePtr))); } else { @@ -2579,7 +2593,7 @@ TEBCresume( TRACE_WITH_OBJ(("=> discarding "), OBJ_AT_TOS); objPtr = POP_OBJECT(); TclDecrRefCount(objPtr); - NEXT_INST_F(1, 0, 0); + NEXT_INST_F0(1, 0); break; case INST_DUP: @@ -2609,12 +2623,22 @@ TEBCresume( b--; } TRACE(("%u => OK\n", opnd)); - NEXT_INST_F(5, 0, 0); + NEXT_INST_F0(5, 0); + } + break; + case INST_SWAP: { + Tcl_Obj *a, *b; + + a = OBJ_AT_TOS; + b = OBJ_UNDER_TOS; + OBJ_UNDER_TOS = a; + OBJ_AT_TOS = b; + TRACE(("=> OK\n")); + NEXT_INST_F0(1, 0); } break; case INST_STR_CONCAT1: - opnd = TclGetUInt1AtPtr(pc+1); DECACHE_STACK_INFO(); objResultPtr = TclStringCat(interp, opnd, &OBJ_AT_DEPTH(opnd-1), @@ -2661,7 +2685,7 @@ TEBCresume( objPtr->length = 0; PUSH_TAUX_OBJ(objPtr); TRACE(("=> mark depth as %" TCL_T_MODIFIER "d\n", CURR_DEPTH)); - NEXT_INST_F(1, 0, 0); + NEXT_INST_F0(1, 0); break; case INST_EXPAND_DROP: @@ -2742,7 +2766,7 @@ TEBCresume( TRACE_APPEND(("OK\n")); Tcl_DecrRefCount(objPtr); - NEXT_INST_F(5, 0, 0); + NEXT_INST_F0(5, 0); } break; @@ -2809,7 +2833,7 @@ TEBCresume( cleanup = objc; #ifdef TCL_COMPILE_DEBUG - if (tclTraceExec >= 2) { + if (tclTraceExec >= TCL_TRACE_BYTECODE_EXEC_COMMANDS) { Tcl_Size i; if (traceInstructions) { @@ -2860,7 +2884,7 @@ TEBCresume( objv = &OBJ_AT_DEPTH(objc-1); cleanup = objc; #ifdef TCL_COMPILE_DEBUG - if (tclTraceExec >= 2) { + if (tclTraceExec >= TCL_TRACE_BYTECODE_EXEC_COMMANDS) { Tcl_Size i; if (traceInstructions) { @@ -3148,13 +3172,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))); #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 */ @@ -3883,7 +3907,7 @@ TEBCresume( } varPtr->value.objPtr = NULL; TRACE_APPEND(("OK\n")); - NEXT_INST_F(6, 0, 0); + NEXT_INST_F0(6, 0); } slowUnsetScalar: @@ -3893,7 +3917,7 @@ TEBCresume( 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; @@ -3923,14 +3947,14 @@ 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: @@ -3946,7 +3970,7 @@ TEBCresume( 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; @@ -4241,7 +4265,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)--; @@ -4267,7 +4291,7 @@ TEBCresume( */ TRACE_APPEND(("link made\n")); - NEXT_INST_F(5, 1, 0); + NEXT_INST_F0(5, 1); } break; @@ -4281,13 +4305,13 @@ TEBCresume( 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); + NEXT_INST_F0(opnd, 0); case INST_JUMP: 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); + NEXT_INST_F0(opnd, 0); { int jmpOffset[2], b; @@ -4344,7 +4368,7 @@ TEBCresume( } } #endif - NEXT_INST_F(jmpOffset[b], 1, 0); + NEXT_INST_F0(jmpOffset[b], 1); } break; @@ -4366,10 +4390,10 @@ TEBCresume( TRACE_APPEND(("found in table, new pc %" TCL_Z_MODIFIER "u\n", (size_t)(pc - codePtr->codeStart + jumpOffset))); - NEXT_INST_F(jumpOffset, 1, 0); + NEXT_INST_F0(jumpOffset, 1); } else { TRACE_APPEND(("not found in table\n")); - NEXT_INST_F(5, 1, 0); + NEXT_INST_F0(5, 1); } } break; @@ -4560,7 +4584,7 @@ TEBCresume( miPtr->mPtr->declaringClassPtr == classPtr) { newDepth = i; #ifdef TCL_COMPILE_DEBUG - if (tclTraceExec >= 2) { + if (tclTraceExec >= TCL_TRACE_BYTECODE_EXEC_COMMANDS) { if (traceInstructions) { strncpy(cmdNameBuf, TclGetString(objv[0]), 20); } else { @@ -4666,7 +4690,7 @@ TEBCresume( CACHE_STACK_INFO(); goto gotError; #ifdef TCL_COMPILE_DEBUG - } else if (tclTraceExec >= 2) { + } else if (tclTraceExec >= TCL_TRACE_BYTECODE_EXEC_COMMANDS) { int i; if (traceInstructions) { @@ -5070,7 +5094,7 @@ TEBCresume( #ifndef TCL_COMPILE_DEBUG if (pc[9] == INST_POP) { - NEXT_INST_F(10, 1, 0); + NEXT_INST_F0(10, 1); } #endif @@ -5079,7 +5103,7 @@ 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; } @@ -5144,7 +5168,6 @@ TEBCresume( goto gotError; } } else { - if (TclListObjLength(interp, value2Ptr, &length) != TCL_OK) { TRACE_ERROR(interp); goto gotError; @@ -5223,7 +5246,7 @@ TEBCresume( goto gotError; } TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr))); - NEXT_INST_F(1, 1, 0); + NEXT_INST_F0(1, 1); } case INST_LREPLACE: { @@ -5391,7 +5414,7 @@ TEBCresume( Tcl_SetObjLength(valuePtr, slength); TclFreeInternalRep(valuePtr); TRACE_APPEND(("\"%.20s\"\n", O2S(valuePtr))); - NEXT_INST_F(1, 0, 0); + NEXT_INST_F0(1, 0); } case INST_STR_LOWER: valuePtr = OBJ_AT_TOS; @@ -5408,7 +5431,7 @@ TEBCresume( Tcl_SetObjLength(valuePtr, slength); TclFreeInternalRep(valuePtr); TRACE_APPEND(("\"%.20s\"\n", O2S(valuePtr))); - NEXT_INST_F(1, 0, 0); + NEXT_INST_F0(1, 0); } case INST_STR_TITLE: valuePtr = OBJ_AT_TOS; @@ -5425,7 +5448,7 @@ TEBCresume( Tcl_SetObjLength(valuePtr, slength); TclFreeInternalRep(valuePtr); TRACE_APPEND(("\"%.20s\"\n", O2S(valuePtr))); - NEXT_INST_F(1, 0, 0); + NEXT_INST_F0(1, 0); } case INST_STR_INDEX: @@ -5510,7 +5533,7 @@ TEBCresume( /* 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. */ @@ -5553,7 +5576,7 @@ TEBCresume( if ((toIdx < 0) || (fromIdx > slength) || (toIdx < fromIdx)) { TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr))); TclDecrRefCount(value3Ptr); - NEXT_INST_F(1, 0, 0); + NEXT_INST_F0(1, 0); } if (fromIdx < 0) { @@ -5568,7 +5591,7 @@ TEBCresume( TclDecrRefCount(OBJ_AT_TOS); OBJ_AT_TOS = value3Ptr; TRACE_APPEND(("\"%.30s\"\n", O2S(value3Ptr))); - NEXT_INST_F(1, 0, 0); + NEXT_INST_F0(1, 0); } objResultPtr = TclStringReplace(interp, valuePtr, fromIdx, @@ -5579,7 +5602,7 @@ TEBCresume( TclDecrRefCount(OBJ_AT_TOS); OBJ_AT_TOS = value3Ptr; TRACE_APPEND(("\"%.30s\"\n", O2S(value3Ptr))); - NEXT_INST_F(1, 0, 0); + NEXT_INST_F0(1, 0); } TclDecrRefCount(value3Ptr); TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); @@ -5772,7 +5795,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 @@ -6138,7 +6161,7 @@ TEBCresume( goto gotError; } else if (objResultPtr == NULL) { TRACE_APPEND(("%s\n", O2S(valuePtr))); - NEXT_INST_F(1, 1, 0); + NEXT_INST_F0(1, 1); } else { TRACE_APPEND(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); @@ -6169,7 +6192,7 @@ TEBCresume( * NaN first argument -> result is also NaN. */ - NEXT_INST_F(1, 1, 0); + NEXT_INST_F0(1, 1); } #endif @@ -6240,7 +6263,7 @@ TEBCresume( } TclSetIntObj(valuePtr, wResult); TRACE(("%s\n", O2S(valuePtr))); - NEXT_INST_F(1, 1, 0); + NEXT_INST_F0(1, 1); break; case INST_DIV: @@ -6304,7 +6327,7 @@ TEBCresume( goto outOfMemory; } else if (objResultPtr == NULL) { TRACE_APPEND(("%s\n", O2S(valuePtr))); - NEXT_INST_F(1, 1, 0); + NEXT_INST_F0(1, 1); } else { TRACE_APPEND(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); @@ -6356,7 +6379,7 @@ TEBCresume( } 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) { @@ -6364,7 +6387,7 @@ TEBCresume( NEXT_INST_F(1, 1, 1); } else { TRACE_APPEND(("%s\n", O2S(valuePtr))); - NEXT_INST_F(1, 0, 0); + NEXT_INST_F0(1, 0); } case INST_UMINUS: @@ -6383,7 +6406,7 @@ TEBCresume( case TCL_NUMBER_NAN: /* -NaN => NaN */ TRACE_APPEND(("%s\n", O2S(valuePtr))); - NEXT_INST_F(1, 0, 0); + NEXT_INST_F0(1, 0); break; case TCL_NUMBER_INT: w1 = *((const Tcl_WideInt *) ptr1); @@ -6395,7 +6418,7 @@ TEBCresume( } TclSetIntObj(valuePtr, -w1); TRACE_APPEND(("%s\n", O2S(valuePtr))); - NEXT_INST_F(1, 0, 0); + NEXT_INST_F0(1, 0); } /* FALLTHROUGH */ } @@ -6405,7 +6428,7 @@ TEBCresume( NEXT_INST_F(1, 1, 1); } else { TRACE_APPEND(("%s\n", O2S(valuePtr))); - NEXT_INST_F(1, 0, 0); + NEXT_INST_F0(1, 0); } case INST_UPLUS: @@ -6435,7 +6458,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) { @@ -6472,7 +6495,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)) { /* @@ -6491,7 +6514,7 @@ TEBCresume( } TclInvalidateStringRep(valuePtr); TRACE_APPEND(("numeric, same Tcl_Obj\n")); - NEXT_INST_F(1, 0, 0); + NEXT_INST_F0(1, 0); } break; @@ -6718,12 +6741,12 @@ 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 @@ -6757,7 +6780,7 @@ TEBCresume( 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; @@ -6772,7 +6795,7 @@ TEBCresume( TRACE(("%u => catchTop=%" TCL_T_MODIFIER "d, stackTop=%" TCL_T_MODIFIER "d\n", TclGetUInt4AtPtr(pc+1), (catchTop - initCatchTop - 1), CURR_DEPTH)); - NEXT_INST_F(5, 0, 0); + NEXT_INST_F0(5, 0); break; case INST_END_CATCH: @@ -6782,7 +6805,7 @@ TEBCresume( CACHE_STACK_INFO(); result = TCL_OK; TRACE(("=> catchTop=%" TCL_Z_MODIFIER "u\n", (size_t)(catchTop - initCatchTop - 1))); - NEXT_INST_F(1, 0, 0); + NEXT_INST_F0(1, 0); break; case INST_PUSH_RESULT: @@ -6827,7 +6850,7 @@ TEBCresume( 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); + NEXT_INST_F0(2*code-1, 1); } case INST_RETURN_CODE_BRANCH: { @@ -6842,10 +6865,53 @@ 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(5*code-4, 1, 0); + TRACE(("\"%s\" => jump offset %d\n", O2S(OBJ_AT_TOS), 5*code-4)); + NEXT_INST_F0(5*code-4, 1); } + 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; + + opnd = TclGetUInt4AtPtr(pc + 1); + value2Ptr = OBJ_AT_TOS; + valuePtr = OBJ_UNDER_TOS; + TRACE(("\"%.20s\" \"%.20s\" %u => ", + O2S(valuePtr), O2S(value2Ptr), opnd)); + 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 < opnd && 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); + } + break; + /* * ----------------------------------------------------------------- * Start of dictionary-related instructions. @@ -6869,7 +6935,7 @@ TEBCresume( goto gotError; } TRACE_APPEND(("OK\n")); - NEXT_INST_F(1, 1, 0); + NEXT_INST_F0(1, 1); } break; @@ -7208,7 +7274,7 @@ 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))); @@ -7344,7 +7410,7 @@ 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); @@ -7365,7 +7431,7 @@ TEBCresume( } 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, @@ -7421,7 +7487,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; @@ -7467,7 +7533,7 @@ 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); @@ -7492,7 +7558,7 @@ TEBCresume( goto gotError; } TRACE_APPEND(("OK\n")); - NEXT_INST_F(5, 2, 0); + NEXT_INST_F0(5, 2); } break; @@ -7600,7 +7666,7 @@ TEBCresume( TRACE_APPEND(("%s, range at %" TCL_SIZE_MODIFIER "d, new pc %" TCL_SIZE_MODIFIER "d\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", @@ -7612,7 +7678,7 @@ TEBCresume( TRACE_APPEND(("%s, range at %" TCL_SIZE_MODIFIER "d, new pc %" TCL_SIZE_MODIFIER "d\n", StringForResultCode(result), rangePtr->codeOffset, rangePtr->continueOffset)); - NEXT_INST_F(0, 0, 0); + NEXT_INST_F0(0, 0); } #ifdef TCL_COMPILE_DEBUG if (traceInstructions) { @@ -7788,7 +7854,7 @@ TEBCresume( } #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. diff --git a/generic/tclLiteral.c b/generic/tclLiteral.c index 38508ec..f52b396 100644 --- a/generic/tclLiteral.c +++ b/generic/tclLiteral.c @@ -616,7 +616,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 diff --git a/generic/tclProc.c b/generic/tclProc.c index d0f4cb9..51cc024 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -1716,7 +1716,7 @@ TclNRInterpProcCore( } #if defined(TCL_COMPILE_DEBUG) - if (tclTraceExec >= 1) { + if (tclTraceExec >= TCL_TRACE_BYTECODE_EXEC_PROCS) { CallFrame *framePtr = iPtr->varFramePtr; Tcl_Size i; @@ -1959,7 +1959,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. diff --git a/win/tcltest.rc b/win/tcltest.rc deleted file mode 100644 index ea55a62..0000000 --- a/win/tcltest.rc +++ /dev/null @@ -1,75 +0,0 @@ -// -// Version Resource Script -// - -#include -#include - -// -// build-up the name suffix that defines the type of build this is. -// -#if STATIC_BUILD -#define SUFFIX_STATIC "s" -#else -#define SUFFIX_STATIC "" -#endif - -#if DEBUG && !UNCHECKED -#define SUFFIX_DEBUG "g" -#else -#define SUFFIX_DEBUG "" -#endif - -#define SUFFIX SUFFIX_STATIC SUFFIX_DEBUG - - -LANGUAGE 0x9, 0x1 /* LANG_ENGLISH, SUBLANG_DEFAULT */ - -VS_VERSION_INFO VERSIONINFO - FILEVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL - PRODUCTVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL - FILEFLAGSMASK 0x3fL -#ifdef DEBUG - FILEFLAGS VS_FF_DEBUG -#else - FILEFLAGS 0x0L -#endif - FILEOS VOS__WINDOWS32 - FILETYPE VFT_APP - FILESUBTYPE 0x0L -BEGIN - BLOCK "StringFileInfo" - BEGIN - BLOCK "040904b0" - BEGIN - VALUE "FileDescription", "Tcltest Application\0" - VALUE "OriginalFilename", "tcltest" STRINGIFY(TCL_MAJOR_VERSION) STRINGIFY(TCL_MINOR_VERSION) SUFFIX ".exe\0" - VALUE "FileVersion", TCL_PATCH_LEVEL - VALUE "LegalCopyright", "Copyright \251 1987-2022 Regents of the University of California and other parties\0" - VALUE "ProductName", "Tcl " TCL_VERSION " for Windows\0" - VALUE "ProductVersion", TCL_PATCH_LEVEL - END - END - BLOCK "VarFileInfo" - BEGIN - VALUE "Translation", 0x409, 1200 - END -END - -// -// Icon -// - -tclsh ICON DISCARDABLE "tclsh.ico" - -// -// This is needed for Windows 8.1 onwards. -// - -#ifndef RT_MANIFEST -#define RT_MANIFEST 24 -#endif -#ifndef CREATEPROCESS_MANIFEST_RESOURCE_ID -#define CREATEPROCESS_MANIFEST_RESOURCE_ID 1 -#endif -CREATEPROCESS_MANIFEST_RESOURCE_ID RT_MANIFEST "tclsh.exe.manifest" -- cgit v0.12 From bf5c26184bb009eb8f8c7bc312d3bc0f1026d955 Mon Sep 17 00:00:00 2001 From: stevel Date: Thu, 10 Apr 2025 04:56:43 +0000 Subject: Updated changes with [tclEpollNotfy PlatformEventsControl panics if websocket disconnected](https://core.tcl-lang.org/tcl/tktview/010d8f38) --- changes.md | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/changes.md b/changes.md index 0a25efc..c6a3829 100644 --- a/changes.md +++ b/changes.md @@ -10,5 +10,6 @@ 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. - +# Bug fixes + - [tclEpollNotfy PlatformEventsControl panics if websocket disconnected](https://core.tcl-lang.org/tcl/tktview/010d8f38) -- cgit v0.12 From 0e3bef140229f3634ae322b472705dbe25a237e0 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 10 Apr 2025 14:22:57 +0000 Subject: First attempt at fixing [92aeb847f9]: proc with more than 2**31 variables. At least, prevent the crash. --- generic/tclProc.c | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/generic/tclProc.c b/generic/tclProc.c index d0f4cb9..7493934 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -637,8 +637,17 @@ TclCreateProc( * local variables for the argument. */ - localPtr = (CompiledLocal *)Tcl_Alloc( + localPtr = (CompiledLocal *)Tcl_AttemptAlloc( offsetof(CompiledLocal, name) + 1U + fieldValues[0]->length); + if (!localPtr) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "procedure \"%s\": arg list contains too many (%" + TCL_SIZE_MODIFIER "d) entries", procName, numArgs)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", + "TOOMANYARGS", (char *)NULL); + goto procError; + } + if (procPtr->firstLocalPtr == NULL) { procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr; } else { -- cgit v0.12 From 68f3bddbba217e20a6bbda89911ba8d7df1e621b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 10 Apr 2025 14:43:12 +0000 Subject: Slight improvement: Cleanup before creating error-message --- generic/tclProc.c | 17 +++++++++++------ 1 file changed, 11 insertions(+), 6 deletions(-) diff --git a/generic/tclProc.c b/generic/tclProc.c index 7493934..7694908 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -414,7 +414,7 @@ TclCreateProc( Tcl_Size i, numArgs; CompiledLocal *localPtr = NULL; Tcl_Obj **argArray; - int precompiled = 0, result; + int precompiled = 0, memoryerror = 0, result; ProcGetInternalRep(bodyPtr, procPtr); if (procPtr != NULL) { @@ -640,11 +640,9 @@ TclCreateProc( localPtr = (CompiledLocal *)Tcl_AttemptAlloc( offsetof(CompiledLocal, name) + 1U + fieldValues[0]->length); if (!localPtr) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "procedure \"%s\": arg list contains too many (%" - TCL_SIZE_MODIFIER "d) entries", procName, numArgs)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", - "TOOMANYARGS", (char *)NULL); + /* Don't set the interp result here. Since a malloc just failed, + * first clean up some memory before doing that */ + memoryerror = 1; goto procError; } @@ -696,6 +694,13 @@ TclCreateProc( } Tcl_Free(procPtr); } + if (memoryerror) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "procedure \"%s\": arg list contains too many (%" + TCL_SIZE_MODIFIER "d) entries", procName, numArgs)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", + "TOOMANYARGS", (char *)NULL); + } return TCL_ERROR; } -- cgit v0.12 From 93c27b3700ed23cacf165140da022499e0d8d53e Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 10 Apr 2025 21:22:41 +0000 Subject: Some definite cleanup of the [switch] issuer, with neater passing of information around --- generic/tclCompCmdsSZ.c | 243 +++++++++++++++++++++++++++++------------------- generic/tclCompUtils.h | 6 +- 2 files changed, 148 insertions(+), 101 deletions(-) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 770efbd..dfed206 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -20,6 +20,17 @@ #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. + 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. */ @@ -53,12 +64,10 @@ 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, Tcl_Size numArms, + SwitchArmInfo *arms); static int IssueTryClausesInstructions(Tcl_Interp *interp, CompileEnv *envPtr, Tcl_Token *bodyToken, int numHandlers, TryHandlerInfo *handlers); @@ -1700,6 +1709,41 @@ TclSubstCompile( /* *---------------------------------------------------------------------- * + * HasDefaultClause, 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 +IsFallthroughArm( + const SwitchArmInfo *arm) /* Which arm to check. */ +{ + return (arm->bodyToken->size == 1) && (arm->bodyToken->start[0] == '-'); +} + +// 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. @@ -1734,10 +1778,7 @@ TclCompileSwitchCmd( /* 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; @@ -1897,40 +1938,56 @@ TclCompileSwitchCmd( if (maxLen < 2) { return TCL_ERROR; } - bodyTokenArray = (Tcl_Token *)TclStackAlloc(interp, sizeof(Tcl_Token) * maxLen); - bodyContLines = (Tcl_Size **)TclStackAlloc(interp, sizeof(Tcl_Size*) * maxLen); - bodyLines = (Tcl_Size *)TclStackAlloc(interp, sizeof(Tcl_Size) * maxLen); - bodyToken = (Tcl_Token **)TclStackAlloc(interp, sizeof(Tcl_Token *) * maxLen); + bodyTokenArray = (Tcl_Token *) TclStackAlloc(interp, + sizeof(Tcl_Token) * maxLen); + arms = (SwitchArmInfo *) TclStackAlloc(interp, + sizeof(SwitchArmInfo) * maxLen / 2); 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 = 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) { + &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) { + 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); @@ -1955,9 +2012,8 @@ TclCompileSwitchCmd( */ bodyTokenArray = NULL; - bodyContLines = (Tcl_Size **)TclStackAlloc(interp, sizeof(Tcl_Size*) * numWords); - bodyLines = (Tcl_Size *)TclStackAlloc(interp, sizeof(Tcl_Size) * numWords); - bodyToken = (Tcl_Token **)TclStackAlloc(interp, sizeof(Tcl_Token *) * numWords); + arms = (SwitchArmInfo *) TclStackAlloc(interp, + sizeof(SwitchArmInfo) * numWords / 2); for (i=0 ; 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] = ExtCmdLocation.line[valueIndex + 1 + i]; - bodyContLines[i] = ExtCmdLocation.next[valueIndex + 1 + i]; + if (isProcessingBody) { + 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); } } @@ -1985,8 +2044,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; } @@ -2002,11 +2060,9 @@ TclCompileSwitchCmd( PUSH_TOKEN( valueTokenPtr, valueIndex); if (mode == Switch_Exact) { - IssueSwitchJumpTable(interp, envPtr, numWords, bodyToken, - bodyLines, bodyContLines); + IssueSwitchJumpTable(interp, envPtr, numWords/2, arms); } else { - IssueSwitchChainedTests(interp, envPtr, mode, noCase, - numWords, bodyToken, bodyLines, bodyContLines); + IssueSwitchChainedTests(interp, envPtr, mode, noCase, numWords/2, arms); } result = TCL_OK; @@ -2015,9 +2071,7 @@ TclCompileSwitchCmd( */ freeTemporaries: - TclStackFree(interp, bodyToken); - TclStackFree(interp, bodyLines); - TclStackFree(interp, bodyContLines); + TclStackFree(interp, arms); if (bodyTokenArray != NULL) { TclStackFree(interp, bodyTokenArray); } @@ -2037,6 +2091,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. + * *---------------------------------------------------------------------- */ @@ -2046,27 +2104,23 @@ 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. */ Tcl_BytecodeLabel *fwdJumps;/* Array of forward-jump fixup locations. */ - int jumpCount; /* Number of places to fix up. */ + int jumpCount; /* Next cell to use in fwdJumps array. */ int contJumpIdx; /* Where the first of the jumps due to a group * of continuation bodies starts, or -1 if * there aren't any. */ int contJumpCount; /* Number of continuation bodies pointing to * the current (or next) real body. */ - int nextArmFixupIndex; + int 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; + int i, j; #define NO_PENDING_JUMP -1 @@ -2077,13 +2131,14 @@ IssueSwitchChainedTests( contJumpIdx = NO_PENDING_JUMP; contJumpCount = 0; fwdJumps = (Tcl_BytecodeLabel *)TclStackAlloc(interp, - sizeof(Tcl_BytecodeLabel) * numBodyTokens); + sizeof(Tcl_BytecodeLabel) * numArms * 2); jumpCount = 0; foundDefault = 0; - for (i=0 ; isize != 7 || - memcmp(bodyToken[numBodyTokens-2]->start, "default", 7)) { + if (i != numArms - 1 || !HasDefaultClause(numArms, arms)) { /* * Generate the test for the arm. */ @@ -2091,11 +2146,11 @@ IssueSwitchChainedTests( switch (mode) { case Switch_Exact: OP( DUP); - TclCompileTokens(interp, bodyToken[i], 1, envPtr); + TclCompileTokens(interp, arm->valueToken, 1, envPtr); OP( STR_EQ); break; case Switch_Glob: - TclCompileTokens(interp, bodyToken[i], 1, envPtr); + TclCompileTokens(interp, arm->valueToken, 1, envPtr); OP4( OVER, 1); OP1( STR_MATCH, noCase); break; @@ -2106,10 +2161,10 @@ 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 == "". @@ -2124,15 +2179,15 @@ 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; TclPushDString(envPtr, &ds); Tcl_DStringFree(&ds); } } if (!simple) { - TclCompileTokens(interp, bodyToken[i], 1, envPtr); + TclCompileTokens(interp, arm->valueToken, 1, envPtr); } OP4( OVER, 1); @@ -2144,8 +2199,7 @@ 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); } else if (exact && !noCase) { @@ -2164,20 +2218,19 @@ IssueSwitchChainedTests( * ensured earlier; the final body is never a fall-through). */ - if (bodyToken[i+1]->size==1 && bodyToken[i+1]->start[0]=='-') { + if (IsFallthroughArm(arm)) { if (contJumpIdx == NO_PENDING_JUMP) { contJumpIdx = jumpCount; contJumpCount = 0; } - FWDJUMP( JUMP_TRUE, fwdJumps[contJumpIdx+contJumpCount]); + FWDJUMP( JUMP_TRUE, fwdJumps[contJumpIdx + contJumpCount]); jumpCount++; contJumpCount++; continue; } FWDJUMP( JUMP_FALSE, fwdJumps[jumpCount]); - nextArmFixupIndex = jumpCount; - jumpCount++; + nextArmFixupIndex = jumpCount++; } else { /* * Got a default clause; set a flag to inhibit the generation of @@ -2200,11 +2253,9 @@ IssueSwitchChainedTests( */ if (contJumpIdx != NO_PENDING_JUMP) { - int j; - for (j=0 ; jline = 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); if (!foundDefault) { FWDJUMP( JUMP, fwdJumps[jumpCount]); @@ -2245,9 +2295,9 @@ IssueSwitchChainedTests( * been fixed. */ - for (i=0 ; ihashTable, TCL_STRING_KEYS); infoIndex = TclCreateAuxData(jtPtr, &tclJumptableInfoType, envPtr); finalFixups = (Tcl_BytecodeLabel *)TclStackAlloc(interp, - sizeof(Tcl_BytecodeLabel) * (numBodyTokens/2)); + sizeof(Tcl_BytecodeLabel) * numArms); foundDefault = 0; mustGenerate = 1; @@ -2317,14 +2366,15 @@ IssueSwitchJumpTable( OP4( JUMP_TABLE, infoIndex); FWDJUMP( JUMP, jumpToDefault); - for (i=0 ; isize != 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, @@ -2334,7 +2384,7 @@ IssueSwitchJumpTable( */ Tcl_DStringInit(&buffer); - TclDStringAppendToken(&buffer, bodyToken[i]); + TclDStringAppendToken(&buffer, arm->valueToken); hPtr = Tcl_CreateHashEntry(&jtPtr->hashTable, Tcl_DStringValue(&buffer), &isNew); if (isNew) { @@ -2365,7 +2415,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; } @@ -2385,9 +2435,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 @@ -2396,7 +2445,7 @@ IssueSwitchJumpTable( * result). */ - if (i+2 < numBodyTokens || !foundDefault) { + if (i < numArms-1 || !foundDefault) { FWDJUMP( JUMP, finalFixups[numRealBodies++]); STKDELTA(-1); } diff --git a/generic/tclCompUtils.h b/generic/tclCompUtils.h index 2846fc2..44495c8 100644 --- a/generic/tclCompUtils.h +++ b/generic/tclCompUtils.h @@ -80,14 +80,12 @@ typedef int Tcl_AuxDataRef; TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr) #define MAKE_LOOP_RANGE() \ TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr) -#define CATCH_RANGE0(range,var) \ +#define CATCH_RANGE_VAR(range,var) \ for(int var=(ExceptionRangeStarts(envPtr,(range)), 0); \ !var; \ var=(ExceptionRangeEnds(envPtr,(range)), 1)) -#define CATCH_RANGE_VAR0(x, y) x ## y -#define CATCH_RANGE_VAR(line) CATCH_RANGE_VAR0(catchRange_, line) #define CATCH_RANGE(range) \ - CATCH_RANGE0((range), CATCH_RANGE_VAR(__LINE__)) + CATCH_RANGE_VAR((range), JOIN(catchRange_, __LINE__)) #define CATCH_TARGET(range) \ ExceptionRangeTarget(envPtr, (range), catchOffset) #define BREAK_TARGET(range) \ -- cgit v0.12 From f3965a147d4df5317b6467333bea8fc2d08c3b3d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 11 Apr 2025 10:36:16 +0000 Subject: Fix [236d18f49b]: More efficient Tcl_FindHashEntry() --- generic/tcl.h | 6 +++++- generic/tclHash.c | 40 +++++++++------------------------------- 2 files changed, 14 insertions(+), 32 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index 016a835..638c00d 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -1155,7 +1155,11 @@ struct Tcl_HashTable { * 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; @@ -2511,7 +2515,7 @@ TclBounceRefCount( #undef Tcl_FindHashEntry #define Tcl_FindHashEntry(tablePtr, key) \ - (*((tablePtr)->findProc))(tablePtr, (const char *)(key)) + (*((tablePtr)->createProc))(tablePtr, (const char *)(key), NULL) #undef Tcl_CreateHashEntry #define Tcl_CreateHashEntry(tablePtr, key, newPtr) \ (*((tablePtr)->createProc))(tablePtr, (const char *)(key), newPtr) diff --git a/generic/tclHash.c b/generic/tclHash.c index 8b33455..b56fc91 100644 --- a/generic/tclHash.c +++ b/generic/tclHash.c @@ -49,7 +49,6 @@ 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, @@ -164,7 +163,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) { @@ -208,7 +209,7 @@ 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, NULL); } /* @@ -495,7 +496,9 @@ Tcl_DeleteHashTable( * re-initialization. */ - tablePtr->findProc = BogusFind; +#ifndef TCL_NO_DEPRECATED + tablePtr->findProc = FindHashEntry; +#endif tablePtr->createProc = BogusCreate; } @@ -874,32 +877,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 @@ -918,9 +895,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_CreateHashEntry" : "Tcl_FindHashEntry"); return NULL; } -- cgit v0.12 From 1c58843ce0087156b1c5e66c20092915a3ce5f51 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 11 Apr 2025 15:46:48 +0000 Subject: Fix and speedup for TclLog2() - only used with TCL_COMPILE_STATS. Can now handle values > 2**31 --- generic/tclCompile.c | 30 +++++++++--------------- generic/tclCompile.h | 4 ++-- generic/tclDisassemble.c | 2 +- generic/tclExecute.c | 60 +++++++++++++++++++++++++++++++----------------- 4 files changed, 53 insertions(+), 43 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 18c11a3..a0ddd08 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1045,8 +1045,8 @@ CleanupByteCode( { Tcl_Interp *interp = (Tcl_Interp *) *codePtr->interpHandle; Interp *iPtr = (Interp *) interp; - int numLitObjects = codePtr->numLitObjects; - int numAuxDataItems = codePtr->numAuxDataItems; + Tcl_Size numLitObjects = codePtr->numLitObjects; + Tcl_Size numAuxDataItems = codePtr->numAuxDataItems; Tcl_Obj **objArrayPtr, *objPtr; const AuxData *auxDataPtr; int i; @@ -1055,7 +1055,7 @@ CleanupByteCode( if (interp != NULL) { ByteCodeStats *statsPtr; Tcl_Time destroyTime; - int lifetimeSec, lifetimeMicroSec, log2; + long long lifetimeSec, lifetimeMicroSec; statsPtr = &iPtr->stats; @@ -1065,7 +1065,7 @@ CleanupByteCode( statsPtr->currentInstBytes -= (double) codePtr->numCodeBytes; statsPtr->currentLitBytes -= (double) - codePtr->numLitObjects * sizeof(Tcl_Obj *); + numLitObjects * sizeof(Tcl_Obj *); statsPtr->currentExceptBytes -= (double) codePtr->numExceptRanges * sizeof(ExceptionRange); statsPtr->currentAuxBytes -= (double) @@ -1074,17 +1074,9 @@ CleanupByteCode( Tcl_GetTime(&destroyTime); lifetimeSec = destroyTime.sec - codePtr->createTime.sec; - if (lifetimeSec > 2000) { /* avoid overflow */ - lifetimeSec = 2000; - } lifetimeMicroSec = 1000000 * lifetimeSec + (destroyTime.usec - codePtr->createTime.usec); - - log2 = TclLog2(lifetimeMicroSec); - if (log2 > 31) { - log2 = 31; - } - statsPtr->lifetimeCount[log2]++; + statsPtr->lifetimeCount[TclLog2(lifetimeMicroSec)]++; } #endif /* TCL_COMPILE_STATS */ @@ -2757,10 +2749,10 @@ TclCompileNoOp( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *tokenPtr; - int i; + Tcl_Size i; tokenPtr = parsePtr->tokenPtr; - for (i = 1; i < (int)parsePtr->numWords; i++) { + for (i = 1; i < parsePtr->numWords; i++) { tokenPtr = tokenPtr + tokenPtr->numComponents + 1; if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { @@ -2841,9 +2833,9 @@ TclInitByteCode( #ifdef TCL_COMPILE_DEBUG unsigned char *nextPtr; #endif - int numLitObjects = envPtr->literalArrayNext; + Tcl_Size i, numLitObjects = envPtr->literalArrayNext; Namespace *namespacePtr; - int i, isNew; + int isNew; Interp *iPtr; if (envPtr->iPtr == NULL) { @@ -4573,8 +4565,8 @@ RecordByteCodeStats( statsPtr->currentSrcBytes += (double) (int)codePtr->numSrcBytes; statsPtr->currentByteCodeBytes += (double) codePtr->structureSize; - statsPtr->srcCount[TclLog2((int)codePtr->numSrcBytes)]++; - statsPtr->byteCodeCount[TclLog2((int) codePtr->structureSize)]++; + statsPtr->srcCount[TclLog2(codePtr->numSrcBytes)]++; + statsPtr->byteCodeCount[TclLog2(codePtr->structureSize)]++; statsPtr->currentInstBytes += (double) codePtr->numCodeBytes; statsPtr->currentLitBytes += (double) diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 2d05cf2..245a891 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -883,7 +883,7 @@ typedef enum InstOperandType { typedef struct InstructionDesc { const char *name; /* Name of instruction. */ - Tcl_Size numBytes; /* Total number of bytes for instruction. */ + int numBytes; /* Total number of bytes for instruction. */ int stackEffect; /* The worst-case balance stack effect of the * instruction, used for stack requirements * computations. The value INT_MIN signals @@ -1165,7 +1165,7 @@ MODULE_SCOPE void TclFinalizeLoopExceptionRange(CompileEnv *envPtr, int range); #ifdef TCL_COMPILE_STATS MODULE_SCOPE char * TclLiteralStats(LiteralTable *tablePtr); -MODULE_SCOPE int TclLog2(int value); +MODULE_SCOPE int TclLog2(long long value); #endif MODULE_SCOPE size_t TclLocalScalar(const char *bytes, size_t numBytes, CompileEnv *envPtr); diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index 6b0b5f1..ffc3026 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -1261,7 +1261,7 @@ DisassembleByteCodeAsDicts( int Tcl_DisassembleObjCmd( - void *clientData, /* What type of operation. */ + void *clientData, /* What type of operation. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 473e226..202364a 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -378,8 +378,8 @@ VarHashCreateVar( #ifdef TCL_COMPILE_DEBUG # define TRACE(a) \ while (traceInstructions) { \ - fprintf(stdout, "%2" TCL_SIZE_MODIFIER "d: %2" TCL_T_MODIFIER \ - "d (%" TCL_T_MODIFIER "d) %s ", iPtr->numLevels, \ + fprintf(stdout, "%2" TCL_SIZE_MODIFIER "d: %2" TCL_SIZE_MODIFIER \ + "d (%" TCL_SIZE_MODIFIER "d) %s ", iPtr->numLevels, \ CURR_DEPTH, \ (pc - codePtr->codeStart), \ GetOpcodeName(pc)); \ @@ -395,8 +395,8 @@ VarHashCreateVar( 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_T_MODIFIER \ - "d (%" TCL_T_MODIFIER "d) %s ", iPtr->numLevels, \ + fprintf(stdout, "%2" TCL_SIZE_MODIFIER "d: %2" TCL_SIZE_MODIFIER \ + "d (%" TCL_SIZE_MODIFIER "d) %s ", iPtr->numLevels, \ CURR_DEPTH, \ (pc - codePtr->codeStart), \ GetOpcodeName(pc)); \ @@ -423,23 +423,23 @@ VarHashCreateVar( do { \ if (TCL_DTRACE_INST_DONE_ENABLED()) { \ if (curInstName) { \ - TCL_DTRACE_INST_DONE(curInstName, (int) 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, (int) CURR_DEPTH, \ + TCL_DTRACE_INST_START(curInstName, CURR_DEPTH, \ tosPtr); \ } \ } else if (TCL_DTRACE_INST_START_ENABLED()) { \ TCL_DTRACE_INST_START(tclInstructionTable[*pc].name, \ - (int) 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, (int) CURR_DEPTH, tosPtr);\ + TCL_DTRACE_INST_DONE(curInstName, CURR_DEPTH, tosPtr);\ } \ } while (0) @@ -2061,7 +2061,7 @@ TEBCresume( #ifdef TCL_COMPILE_DEBUG if (!pc && (tclTraceExec >= 2)) { PrintByteCodeInfo(codePtr); - fprintf(stdout, " Starting stack top=%" TCL_T_MODIFIER "d\n", CURR_DEPTH); + fprintf(stdout, " Starting stack top=%" TCL_SIZE_MODIFIER "d\n", CURR_DEPTH); fflush(stdout); } #endif @@ -2265,7 +2265,7 @@ TEBCresume( CHECK_STACK(); if (traceInstructions) { - fprintf(stdout, "%2" TCL_SIZE_MODIFIER "d: %2" TCL_T_MODIFIER "d ", iPtr->numLevels, CURR_DEPTH); + fprintf(stdout, "%2" TCL_SIZE_MODIFIER "d: %2" TCL_SIZE_MODIFIER "d ", iPtr->numLevels, CURR_DEPTH); TclPrintInstruction(codePtr, pc); fflush(stdout); } @@ -2639,7 +2639,7 @@ TEBCresume( objPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(CURR_DEPTH); objPtr->length = 0; PUSH_TAUX_OBJ(objPtr); - TRACE(("=> mark depth as %" TCL_T_MODIFIER "d\n", CURR_DEPTH)); + TRACE(("=> mark depth as %" TCL_SIZE_MODIFIER "d\n", CURR_DEPTH)); NEXT_INST_F(1, 0, 0); break; @@ -2843,10 +2843,10 @@ TEBCresume( if (traceInstructions) { strncpy(cmdNameBuf, TclGetString(objv[0]), 20); - TRACE(("%" TCL_Z_MODIFIER "u => call (implementation %s) ", objc, O2S(objPtr))); + TRACE(("%" TCL_SIZE_MODIFIER "u => call (implementation %s) ", objc, O2S(objPtr))); } else { fprintf(stdout, - "%" TCL_Z_MODIFIER "d: (%" TCL_T_MODIFIER "u) invoking (using implementation %s) ", + "%" TCL_SIZE_MODIFIER "d: (%" TCL_T_MODIFIER "u) invoking (using implementation %s) ", iPtr->numLevels, (pc - codePtr->codeStart), O2S(objPtr)); } @@ -4298,7 +4298,7 @@ TEBCresume( TRACE(("%d \"%.20s\" => ", opnd, O2S(OBJ_AT_TOS))); hPtr = Tcl_FindHashEntry(&jtPtr->hashTable, TclGetString(OBJ_AT_TOS)); if (hPtr != NULL) { - int jumpOffset = PTR2INT(Tcl_GetHashValue(hPtr)); + 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))); @@ -6692,7 +6692,7 @@ TEBCresume( */ *(++catchTop) = (Tcl_Obj *)INT2PTR(CURR_DEPTH); - TRACE(("%u => catchTop=%" TCL_T_MODIFIER "d, stackTop=%" TCL_T_MODIFIER "d\n", + TRACE(("%u => catchTop=%" TCL_T_MODIFIER "d, stackTop=%" TCL_SIZE_MODIFIER "d\n", TclGetUInt4AtPtr(pc+1), (catchTop - initCatchTop - 1), CURR_DEPTH)); NEXT_INST_F(5, 0, 0); @@ -7727,7 +7727,7 @@ TEBCresume( if (tosPtr < initTosPtr) { fprintf(stderr, "\nTclNRExecuteByteCode: abnormal return at pc %" TCL_T_MODIFIER "d: " - "stack top %" TCL_T_MODIFIER "d < entry stack top %d\n", + "stack top %" TCL_SIZE_MODIFIER "d < entry stack top %d\n", (pc - codePtr->codeStart), CURR_DEPTH, 0); Tcl_Panic("TclNRExecuteByteCode execution failure: end stack top < start stack top"); @@ -9560,14 +9560,32 @@ TclExprFloatError( int TclLog2( - int value) /* The integer for which to compute the log - * base 2. */ + long long value) /* The integer for which to compute the log + * base 2. The maximum output is 31 */ { - int n = value; int result = 0; - while (n > 1) { - n = n >> 1; + if (value > 0x7FFFFF) { + return 31; + } + if (value > 0xFFFF) { + value >>= 16; + result += 16; + } + if (value > 0xFF) { + value >>= 8; + result += 8; + } + if (value > 0xF) { + value >>= 4; + result += 4; + } + if (value > 0x3) { + value >>= 2; + result += 2; + } + if (value > 0x1) { + value >>= 1; result++; } return result; -- cgit v0.12 From 614543396ae44d552a832dd7577ed27ece7be45f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 11 Apr 2025 16:18:01 +0000 Subject: (cherry-pick): Updated changes for [010d8f38]. Indenting --- changes.md | 1 + unix/tclEpollNotfy.c | 18 +++++++++--------- 2 files changed, 10 insertions(+), 9 deletions(-) diff --git a/changes.md b/changes.md index ef977de..7e31472 100644 --- a/changes.md +++ b/changes.md @@ -20,6 +20,7 @@ to the userbase. - [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/010d8f38) # Incompatibilities - No known incompatibilities with the Tcl 9.0.0 public interface. diff --git a/unix/tclEpollNotfy.c b/unix/tclEpollNotfy.c index 0138a00..1446903 100644 --- a/unix/tclEpollNotfy.c +++ b/unix/tclEpollNotfy.c @@ -223,15 +223,15 @@ PlatformEventsControl( */ if (TclOSfstat(filePtr->fd, &fdStat) == -1) { - /* - * The tclEpollNotfy PlatformEventsControl function panics if the TclOSfstat - * call returns -1, which occurs when using a websocket to a browser and the - * browser page is refreshed. It seems the fstat call isn't doing anything - * useful, in particular the contents of the statbuf aren't examined afterwards - * on success and at best it changes the panic message. Instead we avoid the - * panic at the cost of a memory leak. - */ - return; + /* + * The tclEpollNotfy PlatformEventsControl function panics if the TclOSfstat + * call returns -1, which occurs when using a websocket to a browser and the + * browser page is refreshed. It seems the fstat call isn't doing anything + * useful, in particular the contents of the statbuf aren't examined afterwards + * on success and at best it changes the panic message. Instead we avoid the + * panic at the cost of a memory leak. See [010d8f38] + */ + return; } else if (epoll_ctl(tsdPtr->eventsFd, op, filePtr->fd, &newEvent) == -1) { switch (errno) { case EPERM: -- cgit v0.12 From 020cd464d7021ea73f8ded38b0763e697b33ea79 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 12 Apr 2025 08:24:28 +0000 Subject: Attempt to change special value to (int *)-1. Doesn't work yet. --- doc/Hash.3 | 1 + generic/tcl.h | 2 +- generic/tclHash.c | 20 +++++++++++++------- 3 files changed, 15 insertions(+), 8 deletions(-) diff --git a/doc/Hash.3 b/doc/Hash.3 index 09f6a04..2a5ca47 100644 --- a/doc/Hash.3 +++ b/doc/Hash.3 @@ -170,6 +170,7 @@ 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. diff --git a/generic/tcl.h b/generic/tcl.h index 638c00d..f2ad6e8 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2515,7 +2515,7 @@ TclBounceRefCount( #undef Tcl_FindHashEntry #define Tcl_FindHashEntry(tablePtr, key) \ - (*((tablePtr)->createProc))(tablePtr, (const char *)(key), NULL) + (*((tablePtr)->createProc))(tablePtr, (const char *)(key), (int *)-1) #undef Tcl_CreateHashEntry #define Tcl_CreateHashEntry(tablePtr, key, newPtr) \ (*((tablePtr)->createProc))(tablePtr, (const char *)(key), newPtr) diff --git a/generic/tclHash.c b/generic/tclHash.c index b56fc91..5afb97e 100644 --- a/generic/tclHash.c +++ b/generic/tclHash.c @@ -209,7 +209,7 @@ FindHashEntry( Tcl_HashTable *tablePtr, /* Table in which to lookup entry. */ const char *key) /* Key to use to find matching entry. */ { - return tablePtr->createProc(tablePtr, key, NULL); + return tablePtr->createProc(tablePtr, key, (int *)-1); } /* @@ -244,6 +244,9 @@ CreateHashEntry( Tcl_HashEntry *hPtr; const Tcl_HashKeyType *typePtr; size_t hash, index; + if (newPtr == NULL) { + Tcl_Panic("newPtr == NULL"); + } if (tablePtr->keyType == TCL_STRING_KEYS) { typePtr = &tclStringHashKeyType; @@ -283,7 +286,7 @@ CreateHashEntry( /* if keys pointers or values are equal */ if ((key == hPtr->key.oneWordValue) || compareKeysProc((void *) key, hPtr)) { - if (newPtr) { + if (newPtr && (newPtr != (int *)-1)) { *newPtr = 0; } return hPtr; @@ -298,7 +301,7 @@ CreateHashEntry( /* if needle pointer equals content pointer or values equal */ if ((key == hPtr->key.string) || compareKeysProc((void *) key, hPtr)) { - if (newPtr) { + if (newPtr && (newPtr != (int *)-1)) { *newPtr = 0; } return hPtr; @@ -312,7 +315,7 @@ CreateHashEntry( continue; } if (key == hPtr->key.oneWordValue) { - if (newPtr) { + if (newPtr && (newPtr != (int *)-1)) { *newPtr = 0; } return hPtr; @@ -320,7 +323,8 @@ CreateHashEntry( } } - if (!newPtr) { + if (newPtr == (int *)-1) { + /* This is the findProc functionality, so we are done. */ return NULL; } @@ -328,7 +332,9 @@ 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 { @@ -898,7 +904,7 @@ BogusCreate( int *isNew) { Tcl_Panic("called %s on deleted table", - isNew ? "Tcl_CreateHashEntry" : "Tcl_FindHashEntry"); + (isNew && isNew == (int *)-1)? "Tcl_CreateHashEntry" : "Tcl_FindHashEntry"); return NULL; } -- cgit v0.12 From 8b2d2887380bf8427f61d736f0f6ebd3ad88e193 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 12 Apr 2025 08:41:42 +0000 Subject: fix for BogusCreate() --- generic/tclHash.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclHash.c b/generic/tclHash.c index 5afb97e..6cce4c0 100644 --- a/generic/tclHash.c +++ b/generic/tclHash.c @@ -904,7 +904,7 @@ BogusCreate( int *isNew) { Tcl_Panic("called %s on deleted table", - (isNew && isNew == (int *)-1)? "Tcl_CreateHashEntry" : "Tcl_FindHashEntry"); + (isNew && (isNew != (int *)-1))? "Tcl_CreateHashEntry" : "Tcl_FindHashEntry"); return NULL; } -- cgit v0.12 From 8e89253fad1900e36e3eb5351cc611ecb2261efd Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sat, 12 Apr 2025 12:03:19 +0000 Subject: Start on TIP 716 implementation --- win/tclWinInit.c | 79 +++++++++++++++++++++++++++++++++++++++++++++-- win/tclsh.exe.manifest.in | 4 --- 2 files changed, 76 insertions(+), 7 deletions(-) diff --git a/win/tclWinInit.c b/win/tclWinInit.c index 141aff1..57bd63f 100644 --- a/win/tclWinInit.c +++ b/win/tclWinInit.c @@ -63,6 +63,62 @@ static ProcessGlobalValue defaultLibraryDir = {0, 0, NULL, NULL, InitializeDefaultLibraryDir, NULL, NULL}; static ProcessGlobalValue sourceLibraryDir = {0, 0, NULL, NULL, InitializeSourceLibraryDir, NULL, NULL}; + + +/* + * TclpGetWindowsVersionOnce -- + * + * Callback to retrieve Windows version information. To be invoked only + * through InitOnceExecuteOnce for thread safety. + * + * Results: + * None. + */ +static BOOL CALLBACK TclpGetWindowsVersionOnce( + TCL_UNUSED(PINIT_ONCE), + TCL_UNUSED(PVOID), + PVOID *lpContext) +{ + typedef int(__stdcall getVersionProc)(void *); + static OSVERSIONINFOW osInfo; + + /* + * GetVersionExW will not return the "real" Windows version so use + * RtlGetVersion if available and falling back. + */ + HMODULE handle = GetModuleHandleW(L"NTDLL"); + getVersionProc *getVersion = + (getVersionProc *)(void *)GetProcAddress(handle, "RtlGetVersion"); + + osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW); + if (getVersion == NULL || getVersion(&osInfo)) { + if (!GetVersionExW(&osInfo)) { + /* Should never happen but ...*/ + return FALSE; + } + } + *lpContext = (LPVOID)&osInfo; + return TRUE; +} + +/* + * TclpGetWindowsVersion -- + * + * Returns a pointer to the OSVERSIONINFOW structure containing the + * version information for the current Windows version. + * + * Results: + * Pointer to OSVERSIONINFOW structure. + */ +static const OSVERSIONINFOW *TclpGetWindowsVersion(void) +{ + static INIT_ONCE osInfoOnce = INIT_ONCE_STATIC_INIT; + OSVERSIONINFOW *osInfoPtr = NULL; + BOOL result = InitOnceExecuteOnce( + &osInfoOnce, TclpGetWindowsVersionOnce, NULL, &osInfoPtr); + return result ? osInfoPtr : NULL; +} + /* *--------------------------------------------------------------------------- @@ -398,7 +454,7 @@ TclpSetInitialEncodings(void) } const char * -Tcl_GetEncodingNameFromEnvironment( +Tcl_GetEncodingNameForUser( Tcl_DString *bufPtr) { UINT acp = GetACP(); @@ -414,7 +470,24 @@ Tcl_GetEncodingNameFromEnvironment( } return Tcl_DStringValue(bufPtr); } - + +const char * +Tcl_GetEncodingNameFromEnvironment( + Tcl_DString *bufPtr) +{ + OSVERSIONINFOW *osInfoPtr = TclpGetWindowsVersion(); + /* + * TIP 716 - for Build 18362 or higher, force utf-8. Note Windows build + * numbers always increase, so no need to check major / minor versions. + */ + if (osInfoPtr && osInfoPtr->dwBuildNumber >= 18362) { + Tcl_DStringInit(bufPtr); + Tcl_DStringAppend(bufPtr, "utf-8", 5); + return Tcl_DStringValue(bufPtr); + } + return Tcl_GetEncodingNameForUser(bufPtr); +} + const char * TclpGetUserName( Tcl_DString *bufferPtr) /* Uninitialized or free DString filled with @@ -435,7 +508,7 @@ TclpGetUserName( } return Tcl_DStringValue(bufferPtr); } - + /* *--------------------------------------------------------------------------- * diff --git a/win/tclsh.exe.manifest.in b/win/tclsh.exe.manifest.in index dc652e6..dd8a7c5 100644 --- a/win/tclsh.exe.manifest.in +++ b/win/tclsh.exe.manifest.in @@ -35,10 +35,6 @@ xmlns="http://schemas.microsoft.com/SMI/2005/WindowsSettings"> true - - UTF-8 - -- cgit v0.12 From ad696be16d8ed9b6bcd94cb2e015cef73177a928 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sat, 12 Apr 2025 15:11:18 +0000 Subject: Added encoding user command --- generic/tclCmdAH.c | 32 ++++++++++++++++++++++++++++++++ generic/tclInt.h | 3 ++- 2 files changed, 34 insertions(+), 1 deletion(-) diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index ea98a83..877b3bb 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -53,6 +53,7 @@ static Tcl_ObjCmdProc EncodingDirsObjCmd; static Tcl_ObjCmdProc EncodingNamesObjCmd; static Tcl_ObjCmdProc EncodingProfilesObjCmd; static Tcl_ObjCmdProc EncodingSystemObjCmd; +static Tcl_ObjCmdProc EncodingUserObjCmd; static inline int ForeachAssignments(Tcl_Interp *interp, struct ForeachState *statePtr); static inline void ForeachCleanup(Tcl_Interp *interp, @@ -394,6 +395,7 @@ TclInitEncodingCmd( {"names", EncodingNamesObjCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, {"profiles", EncodingProfilesObjCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, {"system", EncodingSystemObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1}, + {"user", EncodingUserObjCmd, TclCompileBasic0ArgCmd, NULL, NULL, 1}, {NULL, NULL, NULL, NULL, NULL, 0} }; @@ -829,6 +831,36 @@ EncodingSystemObjCmd( } /* + *----------------------------------------------------------------------------- + * + * EncodingUserObjCmd -- + * + * This command retrieves the encoding as per the user settings. + * + * Results: + * Returns a standard Tcl result + * + *----------------------------------------------------------------------------- + */ + +int +EncodingUserObjCmd( + TCL_UNUSED(void *), + 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, ""); + return TCL_ERROR; + } + Tcl_DString ds; + Tcl_GetEncodingNameForUser(&ds); + Tcl_DStringResult(interp, &ds); + return TCL_OK; +} + +/* *---------------------------------------------------------------------- * * Tcl_ErrorObjCmd -- diff --git a/generic/tclInt.h b/generic/tclInt.h index 963e850..2dbbc05 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3122,7 +3122,8 @@ 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 */ +MODULE_SCOPE const char *Tcl_GetEncodingNameForUser(Tcl_DString *bufPtr); /* * TIP #233 (Virtualized Time) * Data for the time hooks, if any. -- cgit v0.12 From 6beacbba8a6d92cd22062b84844b6cc2474ad23b Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sat, 12 Apr 2025 16:57:22 +0000 Subject: Added -encoding option to exec --- generic/tclIOCmd.c | 44 +++++++++++++++++++++++++++++++++----------- tests/cmdAH.test | 2 +- tests/exec.test | 2 +- 3 files changed, 35 insertions(+), 13 deletions(-) diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index 712447b..aefefee 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -910,11 +910,12 @@ Tcl_ExecObjCmd( int argc, background, i, index, keepNewline, result, skip, ignoreStderr; Tcl_Size length; static const char *const options[] = { - "-ignorestderr", "-keepnewline", "--", NULL + "-ignorestderr", "-keepnewline", "-encoding", "--", NULL }; enum execOptionsEnum { - EXEC_IGNORESTDERR, EXEC_KEEPNEWLINE, EXEC_LAST + EXEC_IGNORESTDERR, EXEC_KEEPNEWLINE, EXEC_ENCODING, EXEC_LAST }; + Tcl_Obj *encodingObj = NULL; /* * Check for any leading option arguments. @@ -931,12 +932,24 @@ Tcl_ExecObjCmd( TCL_EXACT, &index) != TCL_OK) { return TCL_ERROR; } - if (index == EXEC_KEEPNEWLINE) { + if (index == EXEC_LAST) { + skip++; + break; + } + switch (index) { + case EXEC_KEEPNEWLINE: keepNewline = 1; - } else if (index == EXEC_IGNORESTDERR) { + break; + case EXEC_IGNORESTDERR: ignoreStderr = 1; - } else { - skip++; + break; + case EXEC_ENCODING: + if (++skip >= objc) { + Tcl_SetResult(interp, "No value given for option -encoding.", + TCL_STATIC); + return TCL_ERROR; + } + encodingObj = objv[skip]; break; } } @@ -986,11 +999,6 @@ Tcl_ExecObjCmd( return TCL_ERROR; } - /* Bug [0f1ddc0df7] - encoding errors - use replace profile */ - if (Tcl_SetChannelOption(NULL, chan, "-profile", "replace") != TCL_OK) { - return TCL_ERROR; - } - if (background) { /* * Store the list of PIDs from the pipeline in interp's result and @@ -1004,6 +1012,20 @@ Tcl_ExecObjCmd( return TCL_OK; } + /* Bug [0f1ddc0df7] - encoding errors - use replace profile */ + if (Tcl_SetChannelOption(interp, chan, "-profile", "replace") != TCL_OK) { + return TCL_ERROR; + } + + /* TIP 716 */ + if (encodingObj) { + if (Tcl_SetChannelOption( + interp, chan, "-encoding", Tcl_GetString(encodingObj)) != + TCL_OK) { + return TCL_ERROR; + } + } + TclNewObj(resultPtr); if (Tcl_GetChannelHandle(chan, TCL_READABLE, NULL) == TCL_OK) { if (Tcl_ReadChars(chan, resultPtr, -1, 0) == TCL_IO_FAILURE) { diff --git a/tests/cmdAH.test b/tests/cmdAH.test index 028fbf1..1e64d0f 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -323,7 +323,7 @@ test cmdAH-4.1.1 {encoding} -returnCodes error -body { } -result {wrong # args: should be "encoding subcommand ?arg ...?"} test cmdAH-4.1.2 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding foo -} -result {unknown or ambiguous subcommand "foo": must be convertfrom, convertto, dirs, names, profiles, or system} +} -result {unknown or ambiguous subcommand "foo": must be convertfrom, convertto, dirs, names, profiles, system, or user} # # encoding system 4.2.* diff --git a/tests/exec.test b/tests/exec.test index 141df07..26fe802 100644 --- a/tests/exec.test +++ b/tests/exec.test @@ -568,7 +568,7 @@ test exec-14.2 {-keepnewline switch} -constraints {exec} -body { } -returnCodes error -result {wrong # args: should be "exec ?-option ...? arg ?arg ...?"} test exec-14.3 {unknown switch} -constraints {exec} -body { exec -gorp -} -returnCodes error -result {bad option "-gorp": must be -ignorestderr, -keepnewline, or --} +} -returnCodes error -result {bad option "-gorp": must be -ignorestderr, -keepnewline, -encoding, or --} test exec-14.4 {-- switch} -constraints {exec notValgrind} -body { exec -- -gorp } -returnCodes error -result {couldn't execute "-gorp": no such file or directory} -- cgit v0.12 From ab6d0556fefb9ed7e4fcbb30eb9dafa8adc8b133 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 13 Apr 2025 20:46:43 +0000 Subject: Macros for comparing tokens to literals, making compiler logically easier to read --- generic/tclCompCmds.c | 117 +++++++++++++++++++++--------------------------- generic/tclCompCmdsGR.c | 94 +++++++++++++------------------------- generic/tclCompCmdsSZ.c | 115 +++++++++++++++++++++-------------------------- generic/tclCompUtils.h | 17 +++++++ 4 files changed, 147 insertions(+), 196 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index e309085..bf49d81 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -778,15 +778,9 @@ TclCompileClockClicksCmd( * -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)) { + if (IS_TOKEN_PREFIX(tokenPtr, 3, "-microseconds")) { OP1( CLOCK_READ, 1); - } else if (!strncmp(tokenPtr[1].start, "-milliseconds", - tokenPtr[1].size)) { + } else if (IS_TOKEN_PREFIX(tokenPtr, 3, "-milliseconds")) { OP1( CLOCK_READ, 2); } else { return TCL_ERROR; @@ -861,9 +855,9 @@ TclCompileConcatCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ - Tcl_Obj *objPtr, *listObj; + Tcl_Obj *objPtr, *listObj, **objs; + Tcl_Size len, i; Tcl_Token *tokenPtr; - int i; /* TODO: Consider compiling expansion case. */ if (parsePtr->numWords == 1) { @@ -877,41 +871,35 @@ TclCompileConcatCmd( /* * 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 < parsePtr->numWords; i++) { tokenPtr = TokenAfter(tokenPtr); TclNewObj(objPtr); if (!TclWordKnownAtCompileTime(tokenPtr, objPtr)) { Tcl_BounceRefCount(objPtr); Tcl_BounceRefCount(listObj); - listObj = NULL; - break; + goto runtimeConcat; } (void) Tcl_ListObjAppendElement(NULL, listObj, objPtr); } - if (listObj != NULL) { - Tcl_Obj **objs; - Tcl_Size len; - TclListObjGetElements(NULL, listObj, &len, &objs); - objPtr = Tcl_ConcatObj(len, objs); - Tcl_BounceRefCount(listObj); - PUSH_OBJ( 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 < parsePtr->numWords; i++) { tokenPtr = TokenAfter(tokenPtr); PUSH_TOKEN( tokenPtr, i); } - OP4( CONCAT_STK, i - 1); return TCL_OK; } @@ -1156,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); } @@ -3584,7 +3566,7 @@ TclPushVarName( } 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) == ')')) { + && (varTokenPtr[n].start[varTokenPtr[n].size - 1] == ')')) { /* * Check for parentheses inside first token. */ @@ -3620,34 +3602,35 @@ TclPushVarName( 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 (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; + } } } } diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index a3249ce..4d1639c 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -182,9 +182,8 @@ TclCompileIfCmd( * determined. */ Tcl_Token *tokenPtr, *testTokenPtr; int jumpIndex = 0; /* Avoid compiler warning. */ - size_t numBytes, j; + size_t j; int numWords, wordIdx, code; - const char *word; int realCond = 1; /* Set to 0 for static conditions: * "if 0 {..}" */ int boolVal; /* Value of static condition. */ @@ -221,10 +220,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 +244,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. @@ -268,8 +262,7 @@ TclCompileIfCmd( if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) { TclExpandJumpFixupArray(&jumpFalseFixupArray); } - jumpIndex = jumpFalseFixupArray.next; - jumpFalseFixupArray.next++; + jumpIndex = jumpFalseFixupArray.next++; TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, jumpFalseFixupArray.fixup + jumpIndex); } @@ -287,9 +280,7 @@ TclCompileIfCmd( 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)) { + if (IS_TOKEN_LITERALLY(tokenPtr, "then")) { tokenPtr = TokenAfter(tokenPtr); wordIdx++; if (wordIdx >= numWords) { @@ -357,9 +348,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) { @@ -464,22 +453,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); - - 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; } - Tcl_BounceRefCount(intObj); - if (!haveImmValue) { - PUSH_SIMPLE_TOKEN(incrTokenPtr); - } - } else { + } + Tcl_BounceRefCount(intObj); + if (!haveImmValue) { SetLineInformation(2); CompileTokens(envPtr, incrTokenPtr, interp); } @@ -751,8 +735,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); @@ -1640,8 +1623,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 @@ -1920,24 +1903,15 @@ TclCompileRegexpCmd( for (i = 1; i < (int)parsePtr->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; @@ -1988,8 +1962,7 @@ 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; TclPushDString(envPtr, &ds); Tcl_DStringFree(&ds); @@ -2092,8 +2065,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; } @@ -2250,9 +2222,7 @@ 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); @@ -2807,24 +2777,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; } } diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index dfed206..0436f9a 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -25,7 +25,7 @@ */ typedef struct SwitchArmInfo { Tcl_Token *valueToken; // The value to match for the arm. - Tcl_Token *bodyToken; // The body of an 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; @@ -521,12 +521,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. @@ -540,12 +534,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. @@ -790,12 +783,7 @@ TclCompileStringMatchCmd( */ if (parsePtr->numWords == 4) { - size_t length; - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); - } - length = tokenPtr[1].size; - if ((length <= 1) || strncmp(tokenPtr[1].start, "-nocase", length)) { + if (!IS_TOKEN_PREFIX(tokenPtr, 2, "-nocase")) { /* * Fail at run time, not in compilation. */ @@ -811,25 +799,18 @@ TclCompileStringMatchCmd( */ for (i = 0; i < 2; i++) { - if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - 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(tokenPtr[1].start, - tokenPtr[1].size); + 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. + */ - exactMatch = TclMatchIsTrivial(TclGetString(copy)); - Tcl_BounceRefCount(copy); - } - PUSH_SIMPLE_TOKEN( tokenPtr); - } 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); } @@ -1709,7 +1690,7 @@ TclSubstCompile( /* *---------------------------------------------------------------------- * - * HasDefaultClause, IsFallthroughArm, SetSwitchLineInformation -- + * HasDefaultClause, IsFallthroughToken, IsFallthroughArm, SetSwitchLineInformation -- * * Support utilities for [switch] compilation. * @@ -1724,14 +1705,21 @@ HasDefaultClause( const SwitchArmInfo *arms) /* Array of body information. */ { const Tcl_Token *finalValue = arms[numArms - 1].valueToken; - return (finalValue->size == 7) || !memcmp(finalValue->start, "default", 7); + 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->size == 1) && (arm->bodyToken->start[0] == '-'); + return arm->bodyToken == NULL; } // SetLineInformation() for [switch] bodies @@ -1803,7 +1791,7 @@ TclCompileSwitchCmd( tokenPtr = TokenAfter(parsePtr->tokenPtr); valueIndex = 1; - numWords = parsePtr->numWords-1; + numWords = parsePtr->numWords - 1; /* * Check for options. @@ -1830,9 +1818,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 @@ -1840,11 +1825,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; } @@ -1852,7 +1833,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; } @@ -1860,7 +1841,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; } @@ -1868,11 +1849,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; } @@ -1967,7 +1948,11 @@ TclCompileSwitchCmd( fakeToken->type = TCL_TOKEN_TEXT; fakeToken->numComponents = 0; if (isProcessingBody) { - arm->bodyToken = fakeToken; + if (IsFallthroughToken(fakeToken)) { + arm->bodyToken = NULL; + } else { + arm->bodyToken = fakeToken; + } } else { arm->valueToken = fakeToken; } @@ -2029,7 +2014,11 @@ TclCompileSwitchCmd( } if (isProcessingBody) { - arm->bodyToken = tokenPtr + 1; + 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 { @@ -2803,11 +2792,7 @@ TclCompileTryCmd( 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. */ @@ -2824,8 +2809,7 @@ TclCompileTryCmd( Tcl_ListObjReplace(NULL, tmpObj, 0, 0, 0, NULL); Tcl_IncrRefCount(tmpObj); handlers[handlerIdx].matchClause = tmpObj; - } else if (tokenPtr[1].size == 2 - && !strncmp(tokenPtr[1].start, "on", 2)) { + } else if (IS_TOKEN_LITERALLY(tokenPtr, "on")) { int code; /* @@ -2898,7 +2882,7 @@ TclCompileTryCmd( if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { goto failedToCompile; } - if (tokenPtr[1].size == 1 && tokenPtr[1].start[0] == '-') { + if (IS_TOKEN_LITERALLY(tokenPtr, "-")) { handlers[handlerIdx].tokenPtr = NULL; } else { handlers[handlerIdx].tokenPtr = tokenPtr; @@ -2919,8 +2903,7 @@ 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); @@ -3746,8 +3729,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; } @@ -3755,10 +3742,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) { /* diff --git a/generic/tclCompUtils.h b/generic/tclCompUtils.h index 44495c8..2c354e8 100644 --- a/generic/tclCompUtils.h +++ b/generic/tclCompUtils.h @@ -98,6 +98,23 @@ typedef int Tcl_AuxDataRef; #define STKDELTA(delta) \ TclAdjustStackDepth((delta), envPtr) +#define TokenToObj(tokenPtr) \ + Tcl_NewStringObj((tokenPtr)[1].start, (tokenPtr)[1].size) +#define LENGTH_OF(str) \ + ((Tcl_Size) sizeof(str "") - 1) +#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) +#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) +#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) #endif /* -- cgit v0.12 From 2b0fe4a3ef75940978059b4b33672f2d1c63dced Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 13 Apr 2025 22:16:52 +0000 Subject: Implement Tcl_AttemptCreateHashEntry() --- generic/tcl.h | 33 +++++++++++++++++++++++++++++++-- generic/tclClockFmt.c | 5 ++++- generic/tclHash.c | 23 +++++++++++++++-------- generic/tclObj.c | 10 ++++++---- generic/tclVar.c | 5 ++++- 5 files changed, 60 insertions(+), 16 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index f2ad6e8..06ca3b7 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2513,11 +2513,40 @@ TclBounceRefCount( * hash tables: */ -#undef Tcl_FindHashEntry #define Tcl_FindHashEntry(tablePtr, key) \ (*((tablePtr)->createProc))(tablePtr, (const char *)(key), (int *)-1) -#undef Tcl_CreateHashEntry + +#ifdef TCL_MEM_DEBUG +static inline Tcl_HashEntry * +TclDbPanicIfNull( + Tcl_HashEntry *entry, + int *newPtr, + const char *file, + const char *line) +{ + if (!entry && newPtr != (int *)-1) { + Tcl_Panic("%s: Memory overflow in file %s:%d", "Tcl_CreateHashEntry", file, line); + } + return entry; +} +#define Tcl_CreateHashEntry(tablePtr, key, newPtr) \ + TclDbPanicIfNull((*((tablePtr)->createProc))(tablePtr, (const char *)(key), (newPtr)), (newPtr), __FILE__, __LINE__) +#else +static inline Tcl_HashEntry * +TclPanicIfNull( + Tcl_HashEntry *entry, + int *newPtr) +{ + if (!entry && newPtr != (int *)-1) { + Tcl_Panic("%s: Memory overflow", "Tcl_CreateHashEntry"); + } + return entry; +} #define Tcl_CreateHashEntry(tablePtr, key, newPtr) \ + TclPanicIfNull((*((tablePtr)->createProc))(tablePtr, (const char *)(key), (newPtr)), (newPtr)) +#endif + +#define Tcl_AttemptCreateHashEntry(tablePtr, key, newPtr) \ (*((tablePtr)->createProc))(tablePtr, (const char *)(key), newPtr) #endif /* RC_INVOKED */ diff --git a/generic/tclClockFmt.c b/generic/tclClockFmt.c index 358c4f0..beec218 100644 --- a/generic/tclClockFmt.c +++ b/generic/tclClockFmt.c @@ -565,7 +565,10 @@ ClockFmtScnStorageAllocProc( allocsize -= sizeof(hPtr->key); } - fss = (ClockFmtScnStorage *)Tcl_Alloc(allocsize); + fss = (ClockFmtScnStorage *)Tcl_AttemptAlloc(allocsize); + if (!fss) { + return NULL; + } /* initialize */ memset(fss, 0, sizeof(*fss)); diff --git a/generic/tclHash.c b/generic/tclHash.c index 518ba93..1b4d644 100644 --- a/generic/tclHash.c +++ b/generic/tclHash.c @@ -335,7 +335,10 @@ CreateHashEntry( 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); } @@ -681,10 +684,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; } @@ -779,10 +784,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; } diff --git a/generic/tclObj.c b/generic/tclObj.c index e086c87..500338b 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -4184,11 +4184,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; } diff --git a/generic/tclVar.c b/generic/tclVar.c index 955e4f3..9846102 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -6730,7 +6730,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; -- cgit v0.12 From 63701cbbb51dbffec533377fcc312a39f0e63f6e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 13 Apr 2025 22:39:47 +0000 Subject: Remove comment which is not true any more: TclVarHashFindVar() is not used in Itcl at all. Remove some unnecessary #undef's --- generic/tcl.h | 2 -- generic/tclInt.h | 14 -------------- 2 files changed, 16 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index a959fcd..077c221 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2612,10 +2612,8 @@ TclBounceRefCount( * hash tables: */ -#undef Tcl_FindHashEntry #define Tcl_FindHashEntry(tablePtr, key) \ (*((tablePtr)->findProc))(tablePtr, (const char *)(key)) -#undef Tcl_CreateHashEntry #define Tcl_CreateHashEntry(tablePtr, key, newPtr) \ (*((tablePtr)->createProc))(tablePtr, (const char *)(key), newPtr) diff --git a/generic/tclInt.h b/generic/tclInt.h index 963e850..1eab76d 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -224,20 +224,6 @@ typedef struct TclVarHashTable { #endif /* TCL_MAJOR_VERSION > 8 */ } TclVarHashTable; -/* - * This is for itcl - it likes to search our varTables directly :( - */ - -#define TclVarHashFindVar(tablePtr, key) \ - TclVarHashCreateVar((tablePtr), (key), NULL) - -/* - * Define this to reduce the amount of space that the average namespace - * consumes by only allocating the table of child namespaces when necessary. - * Defining it breaks compatibility for Tcl extensions (e.g., itcl) which - * reach directly into the Namespace structure. - */ - #undef BREAK_NAMESPACE_COMPAT /* -- cgit v0.12 From c2c0e55bcad2a46e901284f3a1b677e6dea7daeb Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 13 Apr 2025 23:00:58 +0000 Subject: Put back a comment, which should not have been removed --- generic/tclInt.h | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/generic/tclInt.h b/generic/tclInt.h index 1eab76d..98cab9b 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -224,6 +224,13 @@ typedef struct TclVarHashTable { #endif /* TCL_MAJOR_VERSION > 8 */ } TclVarHashTable; +/* + * Define this to reduce the amount of space that the average namespace + * consumes by only allocating the table of child namespaces when necessary. + * Defining it breaks compatibility for Tcl extensions (e.g., itcl) which + * reach directly into the Namespace structure. + */ + #undef BREAK_NAMESPACE_COMPAT /* -- cgit v0.12 From 87224fa4f1851fd60e1bf4435f17069759f6f389 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 14 Apr 2025 08:10:56 +0000 Subject: Error-message cleanup --- generic/tclProc.c | 38 +++++++++++++++++--------------------- 1 file changed, 17 insertions(+), 21 deletions(-) diff --git a/generic/tclProc.c b/generic/tclProc.c index 7694908..2cd47d8 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -399,6 +399,8 @@ Tcl_ProcObjCmd( *---------------------------------------------------------------------- */ +static const char TOOMANYARGS[] = "TOOMANYARGS"; + int TclCreateProc( Tcl_Interp *interp, /* Interpreter containing proc. */ @@ -414,7 +416,8 @@ TclCreateProc( Tcl_Size i, numArgs; CompiledLocal *localPtr = NULL; Tcl_Obj **argArray; - int precompiled = 0, memoryerror = 0, result; + int precompiled = 0, result; + const char *errorCode = NULL; ProcGetInternalRep(bodyPtr, procPtr); if (procPtr != NULL) { @@ -502,8 +505,7 @@ TclCreateProc( "procedure \"%s\": arg list contains %" TCL_SIZE_MODIFIER "d entries, " "precompiled header expects %" TCL_SIZE_MODIFIER "d", procName, numArgs, procPtr->numArgs)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", - "BYTECODELIES", (char *)NULL); + errorCode = "BYTECODELIES"; goto procError; } localPtr = procPtr->firstLocalPtr; @@ -532,15 +534,12 @@ TclCreateProc( Tcl_AppendObjToObj(errorObj, argArray[i]); Tcl_AppendToObj(errorObj, "\"", -1); Tcl_SetObjResult(interp, errorObj); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", - "FORMALARGUMENTFORMAT", (char *)NULL); - goto procError; + errorCode = "FORMALARGUMENTFORMAT"; } if ((fieldCount == 0) || (Tcl_GetCharLength(fieldValues[0]) == 0)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "argument with no name", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", - "FORMALARGUMENTFORMAT", (char *)NULL); + errorCode = "FORMALARGUMENTFORMAT"; goto procError; } @@ -558,8 +557,7 @@ TclCreateProc( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "formal parameter \"%s\" is an array element", TclGetString(fieldValues[0]))); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", - "FORMALARGUMENTFORMAT", (char *)NULL); + errorCode = "FORMALARGUMENTFORMAT"; goto procError; } } else if (argnamei[0] == ':' && argnamei[1] == ':') { @@ -568,8 +566,7 @@ TclCreateProc( Tcl_AppendObjToObj(errorObj, fieldValues[0]); Tcl_AppendToObj(errorObj, "\" is not a simple name", -1); Tcl_SetObjResult(interp, errorObj); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", - "FORMALARGUMENTFORMAT", (char *)NULL); + errorCode = "FORMALARGUMENTFORMAT"; goto procError; } argnamei++; @@ -596,8 +593,7 @@ TclCreateProc( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "procedure \"%s\": formal parameter %" TCL_SIZE_MODIFIER "d is " "inconsistent with precompiled body", procName, i)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", - "BYTECODELIES", (char *)NULL); + errorCode = "BYTECODELIES"; goto procError; } @@ -618,8 +614,7 @@ TclCreateProc( Tcl_AppendToObj(errorObj, "\" has " "default value inconsistent with precompiled body", -1); Tcl_SetObjResult(interp, errorObj); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", - "BYTECODELIES", (char *)NULL); + errorCode = "BYTECODELIES"; goto procError; } } @@ -642,10 +637,9 @@ TclCreateProc( if (!localPtr) { /* Don't set the interp result here. Since a malloc just failed, * first clean up some memory before doing that */ - memoryerror = 1; + errorCode = TOOMANYARGS; goto procError; } - if (procPtr->firstLocalPtr == NULL) { procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr; } else { @@ -694,12 +688,14 @@ TclCreateProc( } Tcl_Free(procPtr); } - if (memoryerror) { + if (errorCode) { + if (errorCode == TOOMANYARGS) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "procedure \"%s\": arg list contains too many (%" TCL_SIZE_MODIFIER "d) entries", procName, numArgs)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", - "TOOMANYARGS", (char *)NULL); + } + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", + errorCode, (char *)NULL); } return TCL_ERROR; } -- cgit v0.12 From 1c506bb8576036981a500be7b2da8a6d435e1379 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 14 Apr 2025 08:49:14 +0000 Subject: Update changes.md --- changes.md | 1 + 1 file changed, 1 insertion(+) diff --git a/changes.md b/changes.md index d8bbb43..007e535 100644 --- a/changes.md +++ b/changes.md @@ -22,6 +22,7 @@ to the userbase. - [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) # Incompatibilities - No known incompatibilities with the Tcl 9.0.0 public interface. -- cgit v0.12 From aaf74cba98896715dc76e831037685a2601e53dd Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 14 Apr 2025 09:11:09 +0000 Subject: Minor improvement to [try/finally] instruction sequence --- generic/tclCompCmdsSZ.c | 8 ++++---- generic/tclCompile.c | 4 ++-- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 0436f9a..cb061e1 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -3478,7 +3478,7 @@ IssueTryFinallyInstructions( { DefineLineInformation; /* TIP #280 */ Tcl_ExceptionRange bodyRange, finallyRange; - Tcl_BytecodeLabel jumpOK, jumpSplice, doReturn, endCatch; + Tcl_BytecodeLabel jumpOK, jumpSplice, endCatch; /* * Note that this one is simple enough that we can issue it without @@ -3498,6 +3498,7 @@ IssueTryFinallyInstructions( 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); @@ -3509,6 +3510,7 @@ IssueTryFinallyInstructions( } OP( END_CATCH); OP( POP); + OP( SWAP); FWDJUMP( JUMP, jumpOK); CATCH_TARGET( finallyRange); @@ -3529,12 +3531,10 @@ IssueTryFinallyInstructions( OP4( REVERSE, 4); OP( POP); OP( POP); - FWDJUMP( JUMP, doReturn); // Re-raise FWDLABEL( jumpOK); - OP( SWAP); - FWDLABEL( doReturn); + // Cannot avoid this next op: test-case error-15.9.0.0.2 INVOKE( RETURN_STK); return TCL_OK; } diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 9543a35..cce6f05 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -399,10 +399,10 @@ InstructionDesc const tclInstructionTable[] = { TCL_INSTRUCTION_ENTRY( "listIn", 1, -1), - /* List containment: push [lsearch stktop stknext]>=0) */ + /* List containment: push [lsearch stktop stknext]>=0 */ TCL_INSTRUCTION_ENTRY( "listNotIn", 1, -1), - /* List negated containment: push [lsearch stktop stknext]<0) */ + /* List negated containment: push [lsearch stktop stknext]<0 */ TCL_INSTRUCTION_ENTRY( "pushReturnOpts", 1, +1), -- cgit v0.12 From 45c2d577fb4aa4f79689369151856cce2cf39060 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Mon, 14 Apr 2025 10:46:34 +0000 Subject: Clarify exec manpage << entry that the value is encoded and lineendings converted --- doc/exec.n | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/doc/exec.n b/doc/exec.n index df9b365..4992922 100644 --- a/doc/exec.n +++ b/doc/exec.n @@ -88,7 +88,9 @@ It is used as the standard input for the first command in the pipeline. .TP 15 \fB<<\0\fIvalue\fR . -\fIValue\fR is passed to the first command as its standard input. +\fIValue\fR is encoded using the system encoding, newlines +replaced by platform-specific line ending sequences, and then +passed to the first command as its standard input. .TP 15 \fB>\0\fIfileName\fR . -- cgit v0.12 From 4472e53a9102b1d4bf3a041cc9e4ed3732114ed9 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 14 Apr 2025 11:58:21 +0000 Subject: Put back comment, accidently removed --- generic/tclInt.h | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/generic/tclInt.h b/generic/tclInt.h index 8a1d30a..636b353 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -222,6 +222,13 @@ typedef struct TclVarHashTable { * are variables in an array at all. */ } TclVarHashTable; +/* + * Define this to reduce the amount of space that the average namespace + * consumes by only allocating the table of child namespaces when necessary. + * Defining it breaks compatibility for Tcl extensions (e.g., itcl) which + * reach directly into the Namespace structure. + */ + #undef BREAK_NAMESPACE_COMPAT /* -- cgit v0.12 From b3f2fec373b9f49cb13c8c610196821d559d7874 Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 14 Apr 2025 13:29:57 +0000 Subject: Add [info object creationid] to fully compiled operations; simplify some instruction descriptors --- generic/tclAssembly.c | 20 +-- generic/tclCompCmdsGR.c | 19 +++ generic/tclCompile.c | 383 ++++++++++++++++++++++++------------------------ generic/tclCompile.h | 1 + generic/tclExecute.c | 22 +-- generic/tclInt.h | 1 + generic/tclOOInfo.c | 2 +- tests/assemble.test | 2 +- 8 files changed, 237 insertions(+), 213 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index f658fa7..4b20e1f 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -25,7 +25,7 @@ *- dictUpdateStart, dictUpdateEnd *- jumpTable testing *- syntax (?) - *- returnCodeBranch1, returnCodeBranch4 + *- returnCodeBranch1, returnCodeBranch *- tclooNext, tclooNextClass */ @@ -4172,20 +4172,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/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index bbe5cc1..6d58c90 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -716,6 +716,25 @@ TclCompileInfoObjectClassCmd( } 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; +} + +int TclCompileInfoObjectIsACmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command diff --git a/generic/tclCompile.c b/generic/tclCompile.c index cce6f05..5d2027a 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -36,15 +36,15 @@ static int traceInitialized = 0; * the deprecation here; that's not possible. */ -#define TCL_INSTRUCTION_ENTRY(name,size,stack) \ - {name,size,stack,0,{OPERAND_NONE,OPERAND_NONE}} +#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}} -#define DEPRECATED_INSTRUCTION_ENTRY(name,size,stack) \ - {name,size,stack,0,{OPERAND_NONE,OPERAND_NONE}} +#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) \ @@ -65,307 +65,307 @@ static int traceInitialized = 0; InstructionDesc const tclInstructionTable[] = { /* Name Bytes stackEffect Operand types */ TCL_INSTRUCTION_ENTRY( - "done", 1, -1), + "done", -1), /* Finish ByteCode execution and return stktop (top stack item) */ DEPRECATED_INSTRUCTION_ENTRY1( - "push1", 2, +1, OPERAND_LIT1), + "push1", 2, +1, OPERAND_LIT1), /* Push object at ByteCode objArray[op1] */ TCL_INSTRUCTION_ENTRY1( - "push", 5, +1, OPERAND_LIT4), + "push", 5, +1, OPERAND_LIT4), /* Push object at ByteCode objArray[op4] */ TCL_INSTRUCTION_ENTRY( - "pop", 1, -1), + "pop", -1), /* Pop the topmost stack object */ TCL_INSTRUCTION_ENTRY( - "dup", 1, +1), + "dup", +1), /* Duplicate the topmost stack object and push the result */ TCL_INSTRUCTION_ENTRY1( - "strcat", 2, INT_MIN, OPERAND_UINT1), + "strcat", 2, INT_MIN, OPERAND_UINT1), /* Concatenate the top op1 items and push result */ DEPRECATED_INSTRUCTION_ENTRY1( - "invokeStk1", 2, INT_MIN, OPERAND_UINT1), + "invokeStk1", 2, INT_MIN, OPERAND_UINT1), /* Invoke command named objv[0]; = */ TCL_INSTRUCTION_ENTRY1( - "invokeStk", 5, INT_MIN, OPERAND_UINT4), + "invokeStk", 5, INT_MIN, OPERAND_UINT4), /* Invoke command named objv[0]; = */ TCL_INSTRUCTION_ENTRY( - "evalStk", 1, 0), + "evalStk", 0), /* Evaluate command in stktop using Tcl_EvalObj. */ TCL_INSTRUCTION_ENTRY( - "exprStk", 1, 0), + "exprStk", 0), /* Execute expression in stktop using Tcl_ExprStringObj. */ DEPRECATED_INSTRUCTION_ENTRY1( - "loadScalar1", 2, 1, OPERAND_LVT1), + "loadScalar1", 2, 1, OPERAND_LVT1), /* Load scalar variable at index op1 <= 255 in call frame */ TCL_INSTRUCTION_ENTRY1( - "loadScalar", 5, 1, OPERAND_LVT4), + "loadScalar", 5, 1, OPERAND_LVT4), /* Load scalar variable at index op1 >= 256 in call frame */ TCL_INSTRUCTION_ENTRY( - "loadScalarStk", 1, 0), + "loadScalarStk", 0), /* Load scalar variable; scalar's name is stktop */ DEPRECATED_INSTRUCTION_ENTRY1( - "loadArray1", 2, 0, OPERAND_LVT1), + "loadArray1", 2, 0, OPERAND_LVT1), /* Load array element; array at slot op1<=255, element is stktop */ TCL_INSTRUCTION_ENTRY1( - "loadArray", 5, 0, OPERAND_LVT4), + "loadArray", 5, 0, OPERAND_LVT4), /* Load array element; array at slot op1 > 255, element is stktop */ TCL_INSTRUCTION_ENTRY( - "loadArrayStk", 1, -1), + "loadArrayStk", -1), /* Load array element; element is stktop, array name is stknext */ TCL_INSTRUCTION_ENTRY( - "loadStk", 1, 0), + "loadStk", 0), /* Load general variable; unparsed variable name is stktop */ DEPRECATED_INSTRUCTION_ENTRY1( - "storeScalar1", 2, 0, OPERAND_LVT1), + "storeScalar1", 2, 0, OPERAND_LVT1), /* Store scalar variable at op1<=255 in frame; value is stktop */ TCL_INSTRUCTION_ENTRY1( - "storeScalar", 5, 0, OPERAND_LVT4), + "storeScalar", 5, 0, OPERAND_LVT4), /* Store scalar variable at op1 > 255 in frame; value is stktop */ TCL_INSTRUCTION_ENTRY( - "storeScalarStk", 1, -1), + "storeScalarStk", -1), /* Store scalar; value is stktop, scalar name is stknext */ DEPRECATED_INSTRUCTION_ENTRY1( - "storeArray1", 2, -1, OPERAND_LVT1), + "storeArray1", 2, -1, OPERAND_LVT1), /* Store array element; array at op1<=255, value is top then elem */ TCL_INSTRUCTION_ENTRY1( - "storeArray", 5, -1, OPERAND_LVT4), + "storeArray", 5, -1, OPERAND_LVT4), /* Store array element; array at op1>=256, value is top then elem */ TCL_INSTRUCTION_ENTRY( - "storeArrayStk", 1, -2), + "storeArrayStk", -2), /* Store array element; value is stktop, then elem, array names */ TCL_INSTRUCTION_ENTRY( - "storeStk", 1, -1), + "storeStk", -1), /* Store general variable; value is stktop, then unparsed name */ DEPRECATED_INSTRUCTION_ENTRY1( - "incrScalar1", 2, 0, OPERAND_LVT1), + "incrScalar1", 2, 0, OPERAND_LVT1), /* Incr scalar at index op1<=255 in frame; incr amount is stktop */ TCL_INSTRUCTION_ENTRY( - "incrScalarStk", 1, -1), + "incrScalarStk", -1), /* Incr scalar; incr amount is stktop, scalar's name is stknext */ DEPRECATED_INSTRUCTION_ENTRY1( - "incrArray1", 2, -1, OPERAND_LVT1), + "incrArray1", 2, -1, OPERAND_LVT1), /* Incr array elem; arr at slot op1<=255, amount is top then elem */ TCL_INSTRUCTION_ENTRY( - "incrArrayStk", 1, -2), + "incrArrayStk", -2), /* Incr array element; amount is top then elem then array names */ TCL_INSTRUCTION_ENTRY( - "incrStk", 1, -1), + "incrStk", -1), /* Incr general variable; amount is stktop then unparsed var name */ DEPRECATED_INSTRUCTION_ENTRY2( - "incrScalar1Imm", 3, +1, OPERAND_LVT1, OPERAND_INT1), + "incrScalar1Imm", 3, +1, OPERAND_LVT1, OPERAND_INT1), /* Incr scalar at slot op1 <= 255; amount is 2nd operand byte */ TCL_INSTRUCTION_ENTRY1( - "incrScalarStkImm",2, 0, OPERAND_INT1), + "incrScalarStkImm",2, 0, OPERAND_INT1), /* Incr scalar; scalar name is stktop; incr amount is op1 */ DEPRECATED_INSTRUCTION_ENTRY2( - "incrArray1Imm", 3, 0, OPERAND_LVT1, OPERAND_INT1), + "incrArray1Imm", 3, 0, OPERAND_LVT1, OPERAND_INT1), /* Incr array elem; array at slot op1 <= 255, elem is stktop, * amount is 2nd operand byte */ TCL_INSTRUCTION_ENTRY1( - "incrArrayStkImm",2, -1, OPERAND_INT1), + "incrArrayStkImm",2, -1, OPERAND_INT1), /* Incr array element; elem is top then array name, amount is op1 */ TCL_INSTRUCTION_ENTRY1( - "incrStkImm", 2, 0, OPERAND_INT1), + "incrStkImm", 2, 0, OPERAND_INT1), /* Incr general variable; unparsed name is top, amount is op1 */ DEPRECATED_INSTRUCTION_ENTRY1( - "jump1", 2, 0, OPERAND_OFFSET1), + "jump1", 2, 0, OPERAND_OFFSET1), /* Jump relative to (pc + op1) */ TCL_INSTRUCTION_ENTRY1( - "jump", 5, 0, OPERAND_OFFSET4), + "jump", 5, 0, OPERAND_OFFSET4), /* Jump relative to (pc + op4) */ DEPRECATED_INSTRUCTION_ENTRY1( - "jumpTrue1", 2, -1, OPERAND_OFFSET1), + "jumpTrue1", 2, -1, OPERAND_OFFSET1), /* Jump relative to (pc + op1) if stktop expr object is true */ TCL_INSTRUCTION_ENTRY1( - "jumpTrue", 5, -1, OPERAND_OFFSET4), + "jumpTrue", 5, -1, OPERAND_OFFSET4), /* Jump relative to (pc + op4) if stktop expr object is true */ DEPRECATED_INSTRUCTION_ENTRY1( - "jumpFalse1", 2, -1, OPERAND_OFFSET1), + "jumpFalse1", 2, -1, OPERAND_OFFSET1), /* Jump relative to (pc + op1) if stktop expr object is false */ TCL_INSTRUCTION_ENTRY1( - "jumpFalse", 5, -1, OPERAND_OFFSET4), + "jumpFalse", 5, -1, OPERAND_OFFSET4), /* Jump relative to (pc + op4) if stktop expr object is false */ TCL_INSTRUCTION_ENTRY( - "bitor", 1, -1), + "bitor", -1), /* Bitwise or: push (stknext | stktop) */ TCL_INSTRUCTION_ENTRY( - "bitxor", 1, -1), + "bitxor", -1), /* Bitwise xor push (stknext ^ stktop) */ TCL_INSTRUCTION_ENTRY( - "bitand", 1, -1), + "bitand", -1), /* Bitwise and: push (stknext & stktop) */ TCL_INSTRUCTION_ENTRY( - "eq", 1, -1), + "eq", -1), /* Equal: push (stknext == stktop) */ TCL_INSTRUCTION_ENTRY( - "neq", 1, -1), + "neq", -1), /* Not equal: push (stknext != stktop) */ TCL_INSTRUCTION_ENTRY( - "lt", 1, -1), + "lt", -1), /* Less: push (stknext < stktop) */ TCL_INSTRUCTION_ENTRY( - "gt", 1, -1), + "gt", -1), /* Greater: push (stknext > stktop) */ TCL_INSTRUCTION_ENTRY( - "le", 1, -1), + "le", -1), /* Less or equal: push (stknext <= stktop) */ TCL_INSTRUCTION_ENTRY( - "ge", 1, -1), + "ge", -1), /* Greater or equal: push (stknext >= stktop) */ TCL_INSTRUCTION_ENTRY( - "lshift", 1, -1), + "lshift", -1), /* Left shift: push (stknext << stktop) */ TCL_INSTRUCTION_ENTRY( - "rshift", 1, -1), + "rshift", -1), /* Right shift: push (stknext >> stktop) */ TCL_INSTRUCTION_ENTRY( - "add", 1, -1), + "add", -1), /* Add: push (stknext + stktop) */ TCL_INSTRUCTION_ENTRY( - "sub", 1, -1), + "sub", -1), /* Sub: push (stkext - stktop) */ TCL_INSTRUCTION_ENTRY( - "mult", 1, -1), + "mult", -1), /* Multiply: push (stknext * stktop) */ TCL_INSTRUCTION_ENTRY( - "div", 1, -1), + "div", -1), /* Divide: push (stknext / stktop) */ TCL_INSTRUCTION_ENTRY( - "mod", 1, -1), + "mod", -1), /* Mod: push (stknext % stktop) */ TCL_INSTRUCTION_ENTRY( - "uplus", 1, 0), + "uplus", 0), /* Unary plus: push +stktop */ TCL_INSTRUCTION_ENTRY( - "uminus", 1, 0), + "uminus", 0), /* Unary minus: push -stktop */ TCL_INSTRUCTION_ENTRY( - "bitnot", 1, 0), + "bitnot", 0), /* Bitwise not: push ~stktop */ TCL_INSTRUCTION_ENTRY( - "not", 1, 0), + "not", 0), /* Logical not: push !stktop */ TCL_INSTRUCTION_ENTRY( - "tryCvtToNumeric",1, 0), + "tryCvtToNumeric", 0), /* Try converting stktop to first int then double if possible. */ TCL_INSTRUCTION_ENTRY( - "break", 1, 0), + "break", 0), /* Abort closest enclosing loop; if none, return TCL_BREAK code. */ TCL_INSTRUCTION_ENTRY( - "continue", 1, 0), + "continue", 0), /* Skip to next iteration of closest enclosing loop; if none, return * TCL_CONTINUE code. */ TCL_INSTRUCTION_ENTRY1( - "beginCatch", 5, 0, OPERAND_UINT4), + "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. */ TCL_INSTRUCTION_ENTRY( - "endCatch", 1, 0), + "endCatch", 0), /* End of last catch. Pop the bytecode interpreter's catch stack. */ TCL_INSTRUCTION_ENTRY( - "pushResult", 1, +1), + "pushResult", +1), /* Push the interpreter's object result onto the stack. */ TCL_INSTRUCTION_ENTRY( - "pushReturnCode", 1, +1), + "pushReturnCode", +1), /* Push interpreter's return code (e.g. TCL_OK or TCL_ERROR) as a new * object onto the stack. */ TCL_INSTRUCTION_ENTRY( - "streq", 1, -1), + "streq", -1), /* Str Equal: push (stknext eq stktop) */ TCL_INSTRUCTION_ENTRY( - "strneq", 1, -1), + "strneq", -1), /* Str !Equal: push (stknext neq stktop) */ TCL_INSTRUCTION_ENTRY( - "strcmp", 1, -1), + "strcmp", -1), /* Str Compare: push (stknext cmp stktop) */ TCL_INSTRUCTION_ENTRY( - "strlen", 1, 0), + "strlen", 0), /* Str Length: push (strlen stktop) */ TCL_INSTRUCTION_ENTRY( - "strindex", 1, -1), + "strindex", -1), /* Str Index: push (strindex stknext stktop) */ TCL_INSTRUCTION_ENTRY1( - "strmatch", 2, -1, OPERAND_INT1), + "strmatch", 2, -1, OPERAND_INT1), /* Str Match: push (strmatch stknext stktop) opnd == nocase */ TCL_INSTRUCTION_ENTRY1( - "list", 5, INT_MIN, OPERAND_UINT4), + "list", 5, INT_MIN, OPERAND_UINT4), /* List: push (stk1 stk2 ... stktop) */ TCL_INSTRUCTION_ENTRY( - "listIndex", 1, -1), + "listIndex", -1), /* List Index: push (listindex stknext stktop) */ TCL_INSTRUCTION_ENTRY( - "listLength", 1, 0), + "listLength", 0), /* List Len: push (listlength stktop) */ DEPRECATED_INSTRUCTION_ENTRY1( - "appendScalar1", 2, 0, OPERAND_LVT1), + "appendScalar1", 2, 0, OPERAND_LVT1), /* Append scalar variable at op1<=255 in frame; value is stktop */ TCL_INSTRUCTION_ENTRY1( - "appendScalar", 5, 0, OPERAND_LVT4), + "appendScalar", 5, 0, OPERAND_LVT4), /* Append scalar variable at op1 > 255 in frame; value is stktop */ DEPRECATED_INSTRUCTION_ENTRY1( - "appendArray1", 2, -1, OPERAND_LVT1), + "appendArray1", 2, -1, OPERAND_LVT1), /* Append array element; array at op1<=255, value is top then elem */ TCL_INSTRUCTION_ENTRY1( - "appendArray", 5, -1, OPERAND_LVT4), + "appendArray", 5, -1, OPERAND_LVT4), /* Append array element; array at op1>=256, value is top then elem */ TCL_INSTRUCTION_ENTRY( - "appendArrayStk", 1, -2), + "appendArrayStk", -2), /* Append array element; value is stktop, then elem, array names */ TCL_INSTRUCTION_ENTRY( - "appendStk", 1, -1), + "appendStk", -1), /* Append general variable; value is stktop, then unparsed name */ DEPRECATED_INSTRUCTION_ENTRY1( - "lappendScalar1", 2, 0, OPERAND_LVT1), + "lappendScalar1", 2, 0, OPERAND_LVT1), /* Lappend scalar variable at op1<=255 in frame; value is stktop */ TCL_INSTRUCTION_ENTRY1( - "lappendScalar", 5, 0, OPERAND_LVT4), + "lappendScalar", 5, 0, OPERAND_LVT4), /* Lappend scalar variable at op1 > 255 in frame; value is stktop */ DEPRECATED_INSTRUCTION_ENTRY1( - "lappendArray1", 2, -1, OPERAND_LVT1), + "lappendArray1", 2, -1, OPERAND_LVT1), /* Lappend array element; array at op1<=255, value is top then elem */ TCL_INSTRUCTION_ENTRY1( - "lappendArray", 5, -1, OPERAND_LVT4), + "lappendArray", 5, -1, OPERAND_LVT4), /* Lappend array element; array at op1>=256, value is top then elem */ TCL_INSTRUCTION_ENTRY( - "lappendArrayStk",1, -2), + "lappendArrayStk", -2), /* Lappend array element; value is stktop, then elem, array names */ TCL_INSTRUCTION_ENTRY( - "lappendStk", 1, -1), + "lappendStk", -1), /* Lappend general variable; value is stktop, then unparsed name */ TCL_INSTRUCTION_ENTRY1( - "lindexMulti", 5, INT_MIN, OPERAND_UINT4), + "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. */ TCL_INSTRUCTION_ENTRY1( - "over", 5, +1, OPERAND_UINT4), + "over", 5, +1, OPERAND_UINT4), /* Duplicate the arg-th element from top of stack (TOS=0) */ TCL_INSTRUCTION_ENTRY( - "lsetList", 1, -2), + "lsetList", -2), /* Four-arg version of 'lset'. stktop is old value; next is new * element value, next is the index list; pushes new value */ TCL_INSTRUCTION_ENTRY1( - "lsetFlat", 5, INT_MIN, OPERAND_UINT4), + "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. */ TCL_INSTRUCTION_ENTRY2( - "returnImm", 9, -1, OPERAND_INT4, OPERAND_UINT4), + "returnImm", 9, -1, OPERAND_INT4, OPERAND_UINT4), /* Compiled [return], code, level are operands; options and result * are on the stack. */ TCL_INSTRUCTION_ENTRY( - "expon", 1, -1), + "expon", -1), /* Binary exponentiation operator: push (stknext ** stktop) */ /* @@ -377,13 +377,13 @@ InstructionDesc const tclInstructionTable[] = { * is emitted. */ TCL_INSTRUCTION_ENTRY( - "expandStart", 1, 0), + "expandStart", 0), /* Start of command with {*} (expanded) arguments */ TCL_INSTRUCTION_ENTRY1( - "expandStkTop", 5, 0, OPERAND_UINT4), + "expandStkTop", 5, 0, OPERAND_UINT4), /* Expand the list at stacktop: push its elements on the stack */ TCL_INSTRUCTION_ENTRY( - "invokeExpanded", 1, 0), + "invokeExpanded", 0), /* Invoke the command marked by the last 'expandStart' */ TCL_INSTRUCTION_ENTRY1( @@ -398,34 +398,34 @@ InstructionDesc const tclInstructionTable[] = { * is number of commands here */ TCL_INSTRUCTION_ENTRY( - "listIn", 1, -1), + "listIn", -1), /* List containment: push [lsearch stktop stknext]>=0 */ TCL_INSTRUCTION_ENTRY( - "listNotIn", 1, -1), + "listNotIn", -1), /* List negated containment: push [lsearch stktop stknext]<0 */ TCL_INSTRUCTION_ENTRY( - "pushReturnOpts", 1, +1), + "pushReturnOpts", +1), /* Push the interpreter's return option dictionary as an object on the * stack. */ TCL_INSTRUCTION_ENTRY( - "returnStk", 1, -1), + "returnStk", -1), /* Compiled [return]; options and result are on the stack, code and * level are in the options. */ TCL_INSTRUCTION_ENTRY1( - "dictGet", 5, INT_MIN, OPERAND_UINT4), + "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 */ TCL_INSTRUCTION_ENTRY2( - "dictSet", 9, INT_MIN, OPERAND_UINT4, OPERAND_LVT4), + "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 */ TCL_INSTRUCTION_ENTRY2( - "dictUnset", 9, INT_MIN, OPERAND_UINT4, OPERAND_LVT4), + "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 */ @@ -436,28 +436,28 @@ InstructionDesc const tclInstructionTable[] = { * dictionary at all). op4#1 = incrAmount, op4#2 = LVTindex * Stack: ... key => ... newDict */ TCL_INSTRUCTION_ENTRY1( - "dictAppend", 5, -1, OPERAND_LVT4), + "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 */ TCL_INSTRUCTION_ENTRY1( - "dictLappend", 5, -1, OPERAND_LVT4), + "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 */ TCL_INSTRUCTION_ENTRY1( - "dictFirst", 5, +2, OPERAND_LVT4), + "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 */ TCL_INSTRUCTION_ENTRY1( - "dictNext", 5, +3, OPERAND_LVT4), + "dictNext", 5, +3, OPERAND_LVT4), /* Get the next iteration from the iterator in op4's local scalar. * Stack: ... => ... value key doneBool */ TCL_INSTRUCTION_ENTRY2( - "dictUpdateStart", 9, 0, OPERAND_LVT4, OPERAND_AUX4), + "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 @@ -465,7 +465,7 @@ InstructionDesc const tclInstructionTable[] = { * the list of variables. * Stack: ... keyList => ... keyList */ TCL_INSTRUCTION_ENTRY2( - "dictUpdateEnd", 9, -1, OPERAND_LVT4, OPERAND_AUX4), + "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 @@ -481,111 +481,111 @@ InstructionDesc const tclInstructionTable[] = { * Note that the jump table contains offsets relative to the PC when * it points to this instruction; the code is relocatable. */ TCL_INSTRUCTION_ENTRY1( - "upvar", 5, -1, OPERAND_LVT4), + "upvar", 5, -1, OPERAND_LVT4), /* finds level and otherName in stack, links to local variable at * index op1. Leaves the level on stack. */ TCL_INSTRUCTION_ENTRY1( - "nsupvar", 5, -1, OPERAND_LVT4), + "nsupvar", 5, -1, OPERAND_LVT4), /* finds namespace and otherName in stack, links to local variable at * index op1. Leaves the namespace on stack. */ TCL_INSTRUCTION_ENTRY1( - "variable", 5, -1, OPERAND_LVT4), + "variable", 5, -1, OPERAND_LVT4), /* finds namespace and otherName in stack, links to local variable at * index op1. Leaves the namespace on stack. */ TCL_INSTRUCTION_ENTRY2( - "syntax", 9, -1, OPERAND_INT4, OPERAND_UINT4), + "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. */ TCL_INSTRUCTION_ENTRY1( - "reverse", 5, 0, OPERAND_UINT4), + "reverse", 5, 0, OPERAND_UINT4), /* Reverse the order of the arg elements at the top of stack */ TCL_INSTRUCTION_ENTRY1( - "regexp", 2, -1, OPERAND_INT1), + "regexp", 2, -1, OPERAND_INT1), /* Regexp: push (regexp stknext stktop) opnd == nocase */ TCL_INSTRUCTION_ENTRY1( - "existScalar", 5, 1, OPERAND_LVT4), + "existScalar", 5, 1, OPERAND_LVT4), /* Test if scalar variable at index op1 in call frame exists */ TCL_INSTRUCTION_ENTRY1( - "existArray", 5, 0, OPERAND_LVT4), + "existArray", 5, 0, OPERAND_LVT4), /* Test if array element exists; array at slot op1, element is * stktop */ TCL_INSTRUCTION_ENTRY( - "existArrayStk", 1, -1), + "existArrayStk", -1), /* Test if array element exists; element is stktop, array name is * stknext */ TCL_INSTRUCTION_ENTRY( - "existStk", 1, 0), + "existStk", 0), /* Test if general variable exists; unparsed variable name is stktop*/ TCL_INSTRUCTION_ENTRY( - "nop", 1, 0), + "nop", 0), /* Do nothing */ DEPRECATED_INSTRUCTION_ENTRY( - "returnCodeBranch1", 1,-1), + "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 */ TCL_INSTRUCTION_ENTRY2( - "unsetScalar", 6, 0, OPERAND_UNSF1, OPERAND_LVT4), + "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 */ TCL_INSTRUCTION_ENTRY2( - "unsetArray", 6, -1, OPERAND_UNSF1, OPERAND_LVT4), + "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 */ TCL_INSTRUCTION_ENTRY1( - "unsetArrayStk", 2, -2, OPERAND_UNSF1), + "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 */ TCL_INSTRUCTION_ENTRY1( - "unsetStk", 2, -1, OPERAND_UNSF1), + "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 */ TCL_INSTRUCTION_ENTRY( - "dictExpand", 1, -1), + "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 */ TCL_INSTRUCTION_ENTRY( - "dictRecombineStk", 1, -3), + "dictRecombineStk", -3), /* Map variable contents back into a dictionary in a variable. Part of * [dict with]. * Stack: ... dictVarName path keyList => ... */ TCL_INSTRUCTION_ENTRY1( - "dictRecombineImm", 5, -2, OPERAND_LVT4), + "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 => ... */ TCL_INSTRUCTION_ENTRY1( - "dictExists", 5, INT_MIN, OPERAND_UINT4), + "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 */ TCL_INSTRUCTION_ENTRY( - "verifyDict", 1, -1), + "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 => ... */ TCL_INSTRUCTION_ENTRY( - "strmap", 1, -2), + "strmap", -2), /* Simplified version of [string map] that only applies one change * string, and only case-sensitively. * Stack: ... from to string => ... changedString */ TCL_INSTRUCTION_ENTRY( - "strfind", 1, -1), + "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 */ TCL_INSTRUCTION_ENTRY( - "strrfind", 1, -1), + "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 */ @@ -593,62 +593,62 @@ InstructionDesc const tclInstructionTable[] = { "strrangeImm", 9, 0, OPERAND_IDX4, OPERAND_IDX4), /* String Range: push (string range stktop op4 op4) */ TCL_INSTRUCTION_ENTRY( - "strrange", 1, -2), + "strrange", -2), /* String Range with non-constant arguments. * Stack: ... string idxA idxB => ... substring */ TCL_INSTRUCTION_ENTRY( - "yield", 1, 0), + "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 */ TCL_INSTRUCTION_ENTRY( - "coroName", 1, +1), + "coroName", +1), /* Push the name of the interpreter's current coroutine as an object * on the stack. */ DEPRECATED_INSTRUCTION_ENTRY1( - "tailcall", 2, INT_MIN, OPERAND_UINT1), + "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. */ TCL_INSTRUCTION_ENTRY( - "currentNamespace", 1, +1), + "currentNamespace", +1), /* Push the name of the interpreter's current namespace as an object * on the stack. */ TCL_INSTRUCTION_ENTRY( - "infoLevelNumber", 1, +1), + "infoLevelNumber", +1), /* Push the stack depth (i.e., [info level]) of the interpreter as an * object on the stack. */ TCL_INSTRUCTION_ENTRY( - "infoLevelArgs", 1, 0), + "infoLevelArgs", 0), /* Push the argument words to a stack depth (i.e., [info level ]) * of the interpreter as an object on the stack. * Stack: ... depth => ... argList */ TCL_INSTRUCTION_ENTRY( - "resolveCmd", 1, 0), + "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 */ TCL_INSTRUCTION_ENTRY( - "tclooSelf", 1, +1), + "tclooSelf", +1), /* Push the identity of the current TclOO object (i.e., the name of * its current public access command) on the stack. */ TCL_INSTRUCTION_ENTRY( - "tclooClass", 1, 0), + "tclooClass", 0), /* Push the class of the TclOO object named at the top of the stack * onto the stack. * Stack: ... object => ... class */ TCL_INSTRUCTION_ENTRY( - "tclooNamespace",1, 0), + "tclooNamespace", 0), /* Push the namespace of the TclOO object named at the top of the * stack onto the stack. * Stack: ... object => ... namespace */ TCL_INSTRUCTION_ENTRY( - "tclooIsObject", 1, 0), + "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 @@ -656,21 +656,21 @@ InstructionDesc const tclInstructionTable[] = { * Stack: ... value => ... boolean */ TCL_INSTRUCTION_ENTRY( - "arrayExistsStk",1, 0), + "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 */ TCL_INSTRUCTION_ENTRY1( - "arrayExistsImm",5, +1, OPERAND_LVT4), + "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 */ TCL_INSTRUCTION_ENTRY( - "arrayMakeStk", 1, -1), + "arrayMakeStk", -1), /* Forces the element on the top of the stack to be the name of an * array. * Stack: ... varName => ... */ @@ -686,13 +686,13 @@ InstructionDesc const tclInstructionTable[] = { * = */ TCL_INSTRUCTION_ENTRY( - "listConcat", 1, -1), + "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] */ TCL_INSTRUCTION_ENTRY( - "expandDrop", 1, 0), + "expandDrop", 0), /* Drops an element from the auxiliary stack, popping stack elements * until the matching stack depth is reached. */ @@ -709,7 +709,7 @@ InstructionDesc const tclInstructionTable[] = { * is only nominal. * Stack: ... listObjs... => ... listObjs... iterTracker info */ TCL_INSTRUCTION_ENTRY( - "foreach_step", 1, 0), + "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 @@ -717,65 +717,65 @@ InstructionDesc const tclInstructionTable[] = { * Stack: ... listObjs... iterTracker info => * ... listObjs... iterTracker info */ TCL_INSTRUCTION_ENTRY( - "foreach_end", 1, 0), + "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 => ... */ TCL_INSTRUCTION_ENTRY( - "lmap_collect", 1, -1), + "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 */ TCL_INSTRUCTION_ENTRY( - "strtrim", 1, -1), + "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 */ TCL_INSTRUCTION_ENTRY( - "strtrimLeft", 1, -1), + "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 */ TCL_INSTRUCTION_ENTRY( - "strtrimRight", 1, -1), + "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 */ TCL_INSTRUCTION_ENTRY1( - "concatStk", 5, INT_MIN, OPERAND_UINT4), + "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) */ TCL_INSTRUCTION_ENTRY( - "strcaseUpper", 1, 0), + "strcaseUpper", 0), /* [string toupper] core: converts whole string to upper case using * the default (extended "C" locale) rules. * Stack: ... string => ... newString */ TCL_INSTRUCTION_ENTRY( - "strcaseLower", 1, 0), + "strcaseLower", 0), /* [string tolower] core: converts whole string to upper case using * the default (extended "C" locale) rules. * Stack: ... string => ... newString */ TCL_INSTRUCTION_ENTRY( - "strcaseTitle", 1, 0), + "strcaseTitle", 0), /* [string totitle] core: converts whole string to upper case using * the default (extended "C" locale) rules. * Stack: ... string => ... newString */ TCL_INSTRUCTION_ENTRY( - "strreplace", 1, -3), + "strreplace", -3), /* [string replace] core: replaces a non-empty range of one string * with the contents of another. * Stack: ... string fromIdx toIdx replacement => ... newString */ TCL_INSTRUCTION_ENTRY( - "originCmd", 1, 0), + "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 */ @@ -797,7 +797,7 @@ InstructionDesc const tclInstructionTable[] = { * Stack: ... "nextto" className arg3 arg4 -- argN => ... result */ TCL_INSTRUCTION_ENTRY( - "yieldToInvoke", 1, 0), + "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 @@ -805,11 +805,11 @@ InstructionDesc const tclInstructionTable[] = { * Stack: ... [list ns cmd arg1 ... argN] => ... resumeList */ TCL_INSTRUCTION_ENTRY( - "numericType", 1, 0), + "numericType", 0), /* Pushes the numeric type code of the word at the top of the stack. * Stack: ... value => ... typeCode */ TCL_INSTRUCTION_ENTRY( - "tryCvtToBoolean", 1, +1), + "tryCvtToBoolean", +1), /* Try converting stktop to boolean if possible. No errors. * Stack: ... value => ... value isStrictBool */ TCL_INSTRUCTION_ENTRY1( @@ -828,11 +828,11 @@ InstructionDesc const tclInstructionTable[] = { /* Lappend list to array element; array at op4. * Stack: ... elem list => ... listVarContents */ TCL_INSTRUCTION_ENTRY( - "lappendListArrayStk", 1, -2), + "lappendListArrayStk", -2), /* Lappend list to array element. * Stack: ... arrayName elem list => ... listVarContents */ TCL_INSTRUCTION_ENTRY( - "lappendListStk", 1, -1), + "lappendListStk", -1), /* Lappend list to general variable. * Stack: ... varName list => ... listVarContents */ @@ -843,7 +843,7 @@ InstructionDesc const tclInstructionTable[] = { * Stack: ... => ... time */ TCL_INSTRUCTION_ENTRY1( - "dictGetDef", 5, INT_MIN, OPERAND_UINT4), + "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 @@ -852,19 +852,19 @@ InstructionDesc const tclInstructionTable[] = { * Stack: ... dict key1 ... keyN default => ... value */ TCL_INSTRUCTION_ENTRY( - "strlt", 1, -1), + "strlt", -1), /* String Less: push (stknext < stktop) */ TCL_INSTRUCTION_ENTRY( - "strgt", 1, -1), + "strgt", -1), /* String Greater: push (stknext > stktop) */ TCL_INSTRUCTION_ENTRY( - "strle", 1, -1), + "strle", -1), /* String Less or equal: push (stknext <= stktop) */ TCL_INSTRUCTION_ENTRY( - "strge", 1, -1), + "strge", -1), /* String Greater or equal: push (stknext >= stktop) */ TCL_INSTRUCTION_ENTRY2( - "lreplace", 6, INT_MIN, OPERAND_UINT4, OPERAND_LRPL1), + "lreplace", 6, INT_MIN, OPERAND_UINT4, OPERAND_LRPL1), /* Operands: number of arguments, flags * flags: Combination of TCL_LREPLACE4_* flags * Stack: ... listobj index1 ?index2? new1 ... newN => ... newlistobj @@ -872,46 +872,46 @@ InstructionDesc const tclInstructionTable[] = { * set in flags. */ TCL_INSTRUCTION_ENTRY1( - "constImm", 5, -1, OPERAND_LVT4), + "constImm", 5, -1, OPERAND_LVT4), /* Create constant. Index into LVT is immediate, value is on stack. * Stack: ... value => ... */ TCL_INSTRUCTION_ENTRY( - "constStk", 1, -2), + "constStk", -2), /* Create constant. Variable name and value on stack. * Stack: ... varName value => ... */ TCL_INSTRUCTION_ENTRY( - "returnCodeBranch", 1, -1), + "returnCodeBranch", -1), /* Jump to next instruction based on the return code on top of stack * ERROR: +1; RETURN: +6; BREAK: +11; CONTINUE: +16; * Other non-OK: +21 */ TCL_INSTRUCTION_ENTRY1( - "incrScalar", 5, 0, OPERAND_LVT4), + "incrScalar", 5, 0, OPERAND_LVT4), /* Incr scalar at index op1 in frame; incr amount is stktop */ TCL_INSTRUCTION_ENTRY1( - "incrArray", 5, -1, OPERAND_LVT4), + "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), + "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), + "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), + "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), + "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), + "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 @@ -920,7 +920,7 @@ InstructionDesc const tclInstructionTable[] = { * Stack: ... "nextto" className arg3 arg4 -- argN => ... result */ TCL_INSTRUCTION_ENTRY( - "swap", 1, 0), + "swap", 0), /* Exchanges the top two items on the stack. * Stack: ... val1 val2 => ... val2 val1 */ TCL_INSTRUCTION_ENTRY1( @@ -929,6 +929,11 @@ InstructionDesc const tclInstructionTable[] = { * 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 */ {NULL, 0, 0, 0, {OPERAND_NONE}} }; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index c62ea0a..cdbd3d2 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -890,6 +890,7 @@ enum TclInstruction { INST_SWAP, INST_ERROR_PREFIX_EQ, + INST_TCLOO_ID, /* The last opcode */ LAST_INST_OPCODE diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 5d9ac82..0a0e2ab 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -4760,22 +4760,24 @@ TEBCresume( TRACE_WITH_OBJ(("%.30s => ", O2S(OBJ_AT_TOS)), objResultPtr); NEXT_INST_F(1, 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: oPtr = (Object *) Tcl_GetObjectFromObj(interp, OBJ_AT_TOS); if (oPtr == NULL) { TRACE(("%.30s => ERROR: not object\n", O2S(OBJ_AT_TOS))); goto gotError; } - - objResultPtr = TclNewNamespaceObj(oPtr->namespacePtr); + 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; + } TRACE_WITH_OBJ(("%.30s => ", O2S(OBJ_AT_TOS)), objResultPtr); NEXT_INST_F(1, 1, 1); } diff --git a/generic/tclInt.h b/generic/tclInt.h index e266f62..ea059c2 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3825,6 +3825,7 @@ 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; diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c index 56562dc..aa7d22a 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}, diff --git a/tests/assemble.test b/tests/assemble.test index cc33b8f..fd2a3f6 100644 --- a/tests/assemble.test +++ b/tests/assemble.test @@ -3025,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 } -- cgit v0.12 From f6019494d6d4d290425ff80a3a5fbb9b58a11c59 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 14 Apr 2025 13:43:11 +0000 Subject: Review [56f880ad7b|this] commit: Introduce TclNewNamespaceObj() to factor out a common idiom --- generic/tclNamesp.c | 13 ++++++------- generic/tclResolve.c | 2 +- 2 files changed, 7 insertions(+), 8 deletions(-) diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 65b91f1..fed0dda 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -199,18 +199,18 @@ static const EnsembleImplMap defaultNamespaceMap[] = { static inline Tcl_HashEntry * CreateChildEntry( Namespace *nsPtr, /* Parent namespace. */ - const char *name, /* Simple name to look for. */ - int *isNewPtr) /* Pointer to var with whether this is new. */ + const char *name) /* Simple name to look for. */ { + int newEntry; #ifndef BREAK_NAMESPACE_COMPAT - return Tcl_CreateHashEntry(&nsPtr->childTable, name, isNewPtr); + return Tcl_CreateHashEntry(&nsPtr->childTable, name, &newEntry); #else - if )nsPtr->childTablePtr == NULL) { + 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, isNewPtr); + return Tcl_CreateHashEntry(nsPtr->childTablePtr, name, &newEntry); #endif } @@ -786,7 +786,6 @@ Tcl_CreateNamespace( Tcl_HashEntry *entryPtr; Tcl_DString buffer1, buffer2; Tcl_DString *namePtr, *buffPtr; - int newEntry; size_t nameLen; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); const char *nameStr; @@ -916,7 +915,7 @@ Tcl_CreateNamespace( nsPtr->earlyDeleteProc = NULL; if (parentPtr != NULL) { - entryPtr = CreateChildEntry(parentPtr, simpleName, &newEntry); + entryPtr = CreateChildEntry(parentPtr, simpleName); Tcl_SetHashValue(entryPtr, nsPtr); } else { /* diff --git a/generic/tclResolve.c b/generic/tclResolve.c index f321515..e8023c4 100644 --- a/generic/tclResolve.c +++ b/generic/tclResolve.c @@ -273,7 +273,7 @@ BumpCmdRefEpochs( if (nsPtr->childTablePtr != NULL) { for (entry = Tcl_FirstHashEntry(nsPtr->childTablePtr, &search); entry != NULL; entry = Tcl_NextHashEntry(&search)) { - Namespace *childNsPtr = Tcl_GetHashValue(entry); + Namespace *childNsPtr = (Namespace *)Tcl_GetHashValue(entry); BumpCmdRefEpochs(childNsPtr); } -- cgit v0.12 From 2c5e45746fb246b6c591f67c86edb7a19065c2e1 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Mon, 14 Apr 2025 16:15:05 +0000 Subject: Fix Unix build. Add basic tests --- generic/tclInt.h | 8 ++++++++ tests/encoding.test | 28 +++++++++++++++++++++++++++- tests/exec.test | 14 ++++++++++++++ tests/tcltests.tcl | 19 +++++++++++++++++++ 4 files changed, 68 insertions(+), 1 deletion(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 2dbbc05..948c522 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3123,7 +3123,15 @@ 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. diff --git a/tests/encoding.test b/tests/encoding.test index a754f72..c998e13 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -12,7 +12,7 @@ if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 namespace import -force ::tcltest::* } - +source [file join [file dirname [info script]] tcltests.tcl] namespace eval ::tcl::test::encoding { variable x @@ -1150,6 +1150,32 @@ test encoding-30.3 {encoding convertfrom large strings > 4GB} -constraints { list [string length [set s [string repeat A 0x100000000]]] [string equal $s [encoding convertfrom ascii $s]] } -result {4294967296 1} +# TIP 716 tests +tcltests::testnumargs "encoding user" "" "" +test encoding-31.0 {encoding user} -body { + encoding user +} -result [expr {$::tcl_platform(platform) eq "windows" ? [tcltests::windowscodepage] : [encoding system]}] + +test encoding-31.1 {encoding system does not change encoding user} -setup { + set system [encoding system] + set user [encoding user] +} -body { + encoding system ascii + list [encoding system] [string equal [encoding user] $user] +} -cleanup { + encoding system $system + unset system + unset user +} -result {ascii 1} + +test encoding-31.2 {encoding system on newer Windows always returns utf-8} -body { + string equal [encoding system] \ + [expr { + [tcltests::windowsbuildnumber] > 18362 ? + "utf-8" : [tcltests::windowscodepage] + }] +} -constraints win -result 1 + 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/exec.test b/tests/exec.test index 26fe802..b184d24 100644 --- a/tests/exec.test +++ b/tests/exec.test @@ -48,6 +48,11 @@ set path(echo2) [makeFile { puts stderr [lindex $argv 1] exit } echo2] +set path(echobin) [makeFile { + fconfigure stdout -translation binary + puts -nonewline [binary decode hex [join $argv ""]] + exit +} echobin] set path(cat) [makeFile { if {$argv eq ""} { set argv - @@ -750,6 +755,15 @@ test exec-21.2 {exec encoding mismatch on stderr} -setup { list [catch {exec [info nameofexecutable] $path(script)} r] $r } -result [list 1 a\uFFFDb] +# TIP 716 -encoding option +test exec-22.0 {exec -encoding} -body { + set enc [expr {[encoding system] eq "utf-8" ? "iso2022-jp" : "utf-8"}] + exec -encoding $enc -- [interpreter] $path(echobin) [binary encode hex [encoding convertto $enc \u4e4e\u68d9]] +} -result \u4e4e\u68d9 +test exec-22.1 {exec -encoding invalid encoding} -body { + exec -encoding nosuchencoding -- [interpreter] $path(echobin) abc +} -result {unknown encoding "nosuchencoding"} -returnCodes error + test exec-bug-4f0b5767ac {exec App Execution Alias} -constraints haveWinget -body { exec winget --info } -result "Windows Package Manager*" -match glob diff --git a/tests/tcltests.tcl b/tests/tcltests.tcl index 43f0f60..73080f0 100644 --- a/tests/tcltests.tcl +++ b/tests/tcltests.tcl @@ -116,6 +116,25 @@ namespace eval ::tcltests { -result $message -returnCodes error \ {*}$args } + + # Return Windows version as FULLVERSION MAJOR MINOR BUILD REVISION + if {$::tcl_platform(platform) eq "windows"} { + proc windowsversion {} { + set ver [regexp -inline {(\d+).(\d+).(\d+).(\d+)} [exec {*}[auto_execok ver]]] + proc windowsversion {} [list return $ver] + return [windowsversion] + } + proc windowsbuildnumber {} { + return [lindex [windowsversion] 3] + } + proc windowscodepage {} { + # Note we cannot use result of chcp because that returns OEM code page. + package require registry + set cp [registry get HKEY_LOCAL_MACHINE\\SYSTEM\\CurrentControlSet\\Control\\Nls\\CodePage ACP] + proc windowscodepage {} "return cp$cp" + return [windowscodepage] + } + } } init -- cgit v0.12 From 90f7b103f238ff194fed10610a5f9fa8e78a254f Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 14 Apr 2025 19:28:58 +0000 Subject: Give [dict merge] its own compiler using INST_DICT_PUT; enables better [try] and [dict create] compiling too --- generic/tclAssembly.c | 1 + generic/tclCompCmds.c | 168 ++++++++++++----------- generic/tclCompCmdsGR.c | 121 +++++++--------- generic/tclCompCmdsSZ.c | 34 ++--- generic/tclCompUtils.h | 7 + generic/tclCompile.c | 5 + generic/tclCompile.h | 21 +-- generic/tclDictObj.c | 2 +- generic/tclExecute.c | 356 +++++++++++++++++++++++++----------------------- generic/tclInt.h | 1 + 10 files changed, 355 insertions(+), 361 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 4b20e1f..33e31f0 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -358,6 +358,7 @@ static const TalInstDesc TalInstructionTable[] = { {"dictGetDef", ASSEM_DICT_GET_DEF, INST_DICT_GET_DEF, INT_MIN,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_LVT, INST_DICT_RECOMBINE_IMM,2, 0}, {"dictSet", ASSEM_DICT_SET, INST_DICT_SET, INT_MIN,1}, diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index bf49d81..6e0d20e 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -37,9 +37,9 @@ 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 CompileDictWithEmpty(Tcl_Interp *interp, int numWords, +static inline void IssueDictWithEmpty(Tcl_Interp *interp, int numWords, Tcl_Token *varTokenPtr, CompileEnv *envPtr); -static inline void CompileDictWithBodied(Tcl_Interp *interp, int numWords, +static inline void IssueDictWithBodied(Tcl_Interp *interp, int numWords, Tcl_Token *varTokenPtr, CompileEnv *envPtr); @@ -164,9 +164,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 @@ -267,8 +265,7 @@ TclCompileArrayExistsCmd( } tokenPtr = TokenAfter(parsePtr->tokenPtr); - PushVarNameWord(interp, tokenPtr, envPtr, TCL_NO_ELEMENT, - &localIndex, &isScalar, 1); + PushVarNameWord(tokenPtr, TCL_NO_ELEMENT, &localIndex, &isScalar, 1); if (!isScalar) { return TCL_ERROR; } @@ -345,8 +342,7 @@ TclCompileArraySetCmd( goto done; } - PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_ELEMENT, - &localIndex, &isScalar, 1); + PushVarNameWord(varTokenPtr, TCL_NO_ELEMENT, &localIndex, &isScalar, 1); if (!isScalar) { code = TCL_ERROR; goto done; @@ -480,8 +476,7 @@ TclCompileArrayUnsetCmd( 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; } @@ -592,7 +587,7 @@ TclCompileCatchCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *cmdTokenPtr, *resultNameTokenPtr, *optsNameTokenPtr; - int dropScript = 0; + int dropScript = 0, numWords = parsePtr->numWords; Tcl_LVTIndex resultIndex, optsIndex; Tcl_BytecodeLabel haveResultAndCode; Tcl_ExceptionRange range; @@ -603,7 +598,7 @@ TclCompileCatchCmd( * 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; } @@ -612,7 +607,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; } @@ -623,7 +618,7 @@ TclCompileCatchCmd( resultIndex = optsIndex = -1; cmdTokenPtr = TokenAfter(parsePtr->tokenPtr); - if ((int)parsePtr->numWords >= 3) { + if (numWords >= 3) { resultNameTokenPtr = TokenAfter(cmdTokenPtr); /* DGP */ resultIndex = LocalScalarFromToken(resultNameTokenPtr, envPtr); @@ -632,7 +627,7 @@ TclCompileCatchCmd( } /* DKF */ - if (parsePtr->numWords == 4) { + if (numWords == 4) { optsNameTokenPtr = TokenAfter(resultNameTokenPtr); optsIndex = LocalScalarFromToken(optsNameTokenPtr, envPtr); if (optsIndex < 0) { @@ -951,8 +946,7 @@ 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 @@ -1283,6 +1277,43 @@ TclCompileDictExistsCmd( } 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 */ + int i, numWords = (int) parsePtr->numWords; + Tcl_Token *tokenPtr; + + /* + * Don't compile [dict replace $dict]; it's an edge case. + */ + if (numWords <= 3 || (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; inumWords; - if ((parsePtr->numWords & 1) == 0) { + if ((numWords & 1) == 0) { return TCL_ERROR; } @@ -1360,7 +1389,7 @@ TclCompileDictCreateCmd( keyToken = TokenAfter(parsePtr->tokenPtr); TclNewObj(dictObj); - for (i=1 ; i<(int)parsePtr->numWords ; i+=2) { + for (i=1 ; itokenPtr); - for (i=1 ; i<(int)parsePtr->numWords ; i+=2) { + for (i=1 ; inumWords; + Tcl_LVTIndex infoIndex; Tcl_ExceptionRange outLoop; Tcl_BytecodeLabel end; @@ -1444,10 +1460,10 @@ TclCompileDictMergeCmd( */ /* TODO: Consider support for compiling expanded args. (less likely) */ - if ((int)parsePtr->numWords < 2) { + if (numWords < 2) { PUSH( ""); return TCL_OK; - } else if (parsePtr->numWords == 2) { + } else if (numWords == 2) { tokenPtr = TokenAfter(parsePtr->tokenPtr); PUSH_TOKEN( tokenPtr, 1); OP( DUP); @@ -1465,10 +1481,6 @@ TclCompileDictMergeCmd( if (!EnvHasLVT(envPtr)) { return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr); } - worker = AnonymousLocal(envPtr); - if (worker < 0) { - return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr); - } infoIndex = AnonymousLocal(envPtr); /* @@ -1479,8 +1491,6 @@ TclCompileDictMergeCmd( PUSH_TOKEN( tokenPtr, 1); OP( DUP); OP( DICT_VERIFY); - OP4( STORE_SCALAR, worker); - OP( POP); /* * For each of the remaining dictionaries... @@ -1489,7 +1499,7 @@ TclCompileDictMergeCmd( outLoop = MAKE_CATCH_RANGE(); OP4( BEGIN_CATCH, outLoop); CATCH_RANGE(outLoop) { - for (i=2 ; i<(int)parsePtr->numWords ; i++) { + for (i=2 ; inumWords; Tcl_AuxDataRef infoIndex; Tcl_LVTIndex dictIndex; Tcl_ExceptionRange range; @@ -1800,7 +1806,7 @@ TclCompileDictUpdateCmd( * There must be at least one argument after the command. */ - if ((int)parsePtr->numWords < 5) { + if (numWords < 5) { return TCL_ERROR; } @@ -1809,10 +1815,10 @@ TclCompileDictUpdateCmd( * dict update ? ...? */ - 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 @@ -1879,7 +1885,7 @@ TclCompileDictUpdateCmd( range = MAKE_CATCH_RANGE(); OP4( BEGIN_CATCH, range); CATCH_RANGE(range) { - BODY( bodyTokenPtr, parsePtr->numWords - 1); + BODY( bodyTokenPtr, numWords - 1); } /* @@ -1938,7 +1944,7 @@ TclCompileDictAppendCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - int i; + int i, numWords = parsePtr->numWords; Tcl_LVTIndex dictVarIndex; /* @@ -1948,7 +1954,7 @@ TclCompileDictAppendCmd( */ /* TODO: Consider support for compiling expanded args. */ - if ((int)parsePtr->numWords<4 || (int)parsePtr->numWords>100) { + if (numWords < 4 || numWords > 100) { return TCL_ERROR; } @@ -1967,12 +1973,12 @@ TclCompileDictAppendCmd( */ tokenPtr = TokenAfter(tokenPtr); - for (i=2 ; i<(int)parsePtr->numWords ; i++) { + for (i=2 ; inumWords > 4) { - OP1( STR_CONCAT1, (int)parsePtr->numWords - 3); + if (numWords > 4) { + OP1( STR_CONCAT1, numWords - 3); } /* @@ -2028,8 +2034,8 @@ TclCompileDictLappendCmd( return TCL_OK; } -/* Compile [dict with]. Delegates code issuing to CompileDictWithEmpty() and - * CompileDictWithBodied(). */ +/* Compile [dict with]. Delegates code issuing to IssueDictWithEmpty() and + * IssueDictWithBodied(). */ int TclCompileDictWithCmd( Tcl_Interp *interp, /* Used for looking up stuff. */ @@ -2100,7 +2106,7 @@ TclCompileDictWithCmd( * free of traces. */ - CompileDictWithEmpty(interp, numWords, varTokenPtr, envPtr); + IssueDictWithEmpty(interp, numWords, varTokenPtr, envPtr); } else { /* * OK, we have a non-trivial body. This means that the focus is on @@ -2108,14 +2114,14 @@ TclCompileDictWithCmd( * goes in the 'finally' clause. */ - CompileDictWithBodied(interp, numWords, varTokenPtr, envPtr); + IssueDictWithBodied(interp, numWords, varTokenPtr, envPtr); } return TCL_OK; } /* Issue code for a [dict with] that has an entirely trivial body. */ static inline void -CompileDictWithEmpty( +IssueDictWithEmpty( Tcl_Interp *interp, int numWords, Tcl_Token *varTokenPtr, @@ -2205,7 +2211,7 @@ CompileDictWithEmpty( /* Issue code for a [dict with] that has a non-trivial body. */ static inline void -CompileDictWithBodied( +IssueDictWithBodied( Tcl_Interp *interp, int numWords, Tcl_Token *varTokenPtr, @@ -2456,12 +2462,13 @@ TclCompileErrorCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; + int 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; } @@ -2476,13 +2483,13 @@ TclCompileErrorCmd( * Construct the options. Note that -code and -level are not here. */ - if (parsePtr->numWords == 2) { + if (numWords == 2) { PUSH( ""); } else { PUSH( "-errorinfo"); tokenPtr = TokenAfter(tokenPtr); PUSH_TOKEN( tokenPtr, 2); - if (parsePtr->numWords == 3) { + if (numWords == 3) { OP4( LIST, 2); } else { PUSH( "-errorcode"); @@ -3238,13 +3245,13 @@ TclCompileFormatCmd( Tcl_Token *tokenPtr = parsePtr->tokenPtr; Tcl_Obj **objv, *formatObj, *tmpObj; const char *bytes, *start; - int i, j; + int i, j, numWords = parsePtr->numWords; /* * Don't handle any guaranteed-error cases. */ - if ((int)parsePtr->numWords < 2) { + if (numWords < 2) { return TCL_ERROR; } @@ -3261,8 +3268,8 @@ TclCompileFormatCmd( return TCL_ERROR; } - objv = (Tcl_Obj **)TclStackAlloc(interp, (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]); @@ -3276,8 +3283,7 @@ 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]); } @@ -3336,7 +3342,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; } diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 6d58c90..abcdc50 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -441,9 +441,7 @@ TclCompileIncrCmd( } varTokenPtr = TokenAfter(parsePtr->tokenPtr); - - PushVarNameWord(interp, varTokenPtr, envPtr, 0, - &localIndex, &isScalar, 1); + PushVarNameWord(varTokenPtr, 0, &localIndex, &isScalar, 1); /* * If an increment is given, push it, but see first if it's a small @@ -639,7 +637,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. @@ -815,11 +813,10 @@ TclCompileLappendCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr, *valueTokenPtr; - int isScalar, numWords, i; + int isScalar, numWords = (int) parsePtr->numWords, i; Tcl_LVTIndex localIndex; /* TODO: Consider support for compiling expanded args. */ - numWords = parsePtr->numWords; if (numWords < 3) { return TCL_ERROR; } @@ -837,9 +834,7 @@ TclCompileLappendCmd( */ 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. In the no values @@ -878,8 +873,7 @@ TclCompileLappendCmd( lappendMultiple: varTokenPtr = TokenAfter(parsePtr->tokenPtr); - PushVarNameWord(interp, varTokenPtr, envPtr, 0, - &localIndex, &isScalar, 1); + PushVarNameWord(varTokenPtr, 0, &localIndex, &isScalar, 1); valueTokenPtr = TokenAfter(varTokenPtr); for (i = 2 ; i < numWords ; i++) { PUSH_TOKEN( valueTokenPtr, i); @@ -930,11 +924,9 @@ TclCompileLassignCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - int isScalar, numWords, idx; + int isScalar, numWords = (int) parsePtr->numWords, idx; Tcl_LVTIndex localIndex; - numWords = parsePtr->numWords; - /* * Check for command syntax error, but we'll punt that to runtime. */ @@ -955,14 +947,12 @@ TclCompileLassignCmd( */ for (idx=0 ; idxnumWords; + int i, idx, numWords = (int) parsePtr->numWords; /* * Quit if not enough args. @@ -1123,10 +1113,10 @@ TclCompileListCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *valueTokenPtr; - int i, numWords, concat, build; + int i, numWords = (int) parsePtr->numWords, concat, build; Tcl_Obj *listObj, *objPtr; - if (parsePtr->numWords == 1) { + if (numWords == 1) { /* * [list] without arguments just pushes an empty object. */ @@ -1140,7 +1130,6 @@ TclCompileListCmd( * implement with a simple push. */ - numWords = parsePtr->numWords; valueTokenPtr = TokenAfter(parsePtr->tokenPtr); TclNewObj(listObj); for (i = 1; i < numWords && listObj != NULL; i++) { @@ -1163,7 +1152,6 @@ TclCompileListCmd( * Push the all values onto the stack. */ - numWords = parsePtr->numWords; valueTokenPtr = TokenAfter(parsePtr->tokenPtr); concat = build = 0; for (i = 1; i < numWords; i++) { @@ -1326,9 +1314,9 @@ TclCompileLinsertCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *listToken, *indexToken, *tokenPtr; - Tcl_Size i; + Tcl_Size i, numWords = parsePtr->numWords; - if (parsePtr->numWords < 3 || parsePtr->numWords > 0x7FFFFFFF) { + if (numWords < 3 || numWords > 0x7FFFFFFF) { return TCL_ERROR; } @@ -1341,7 +1329,7 @@ TclCompileLinsertCmd( /* Push new elements to be inserted */ tokenPtr = TokenAfter(indexToken); - for (i=3 ; inumWords ; i++,tokenPtr=TokenAfter(tokenPtr)) { + for (i=3 ; inumWords - 1, + OP41( LREPLACE, numWords - 1, TCL_LREPLACE4_SINGLE_INDEX); return TCL_OK; } @@ -1378,9 +1366,9 @@ TclCompileLreplaceCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *listToken, *firstToken, *lastToken, *tokenPtr; - Tcl_Size i; + Tcl_Size i, numWords = parsePtr->numWords; - if (parsePtr->numWords < 4 || parsePtr->numWords > 0x7FFFFFFF) { + if (numWords < 4 || numWords > 0x7FFFFFFF) { return TCL_ERROR; } @@ -1395,7 +1383,7 @@ TclCompileLreplaceCmd( /* Push new elements to be inserted */ tokenPtr = TokenAfter(lastToken); - for (i=4; inumWords; i++,tokenPtr=TokenAfter(tokenPtr)) { + for (i=4; inumWords - 1, + OP41( LREPLACE, numWords - 1, TCL_LREPLACE4_END_IS_LAST); return TCL_OK; } @@ -1464,6 +1452,7 @@ TclCompileLsetCmd( * parse of the variable name. */ Tcl_LVTIndex localIndex; /* Index of var in local var table. */ int isScalar; /* Flag == 1 if scalar, 0 if array. */ + int numWords = (int) parsePtr->numWords; int i; /* @@ -1471,7 +1460,7 @@ TclCompileLsetCmd( */ /* TODO: Consider support for compiling expanded args. */ - if ((int)parsePtr->numWords < 3) { + if (numWords < 3) { /* * Fail at run time, not in compilation. */ @@ -1488,14 +1477,13 @@ 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 ; inumWords - 2; - } else { - tempDepth = parsePtr->numWords - 1; - } + tempDepth = numWords - (isScalar ? 2 : 1); OP4( OVER, tempDepth); } @@ -1518,11 +1502,7 @@ TclCompileLsetCmd( */ if (!isScalar) { - if (localIndex < 0) { - tempDepth = parsePtr->numWords - 1; - } else { - tempDepth = parsePtr->numWords - 2; - } + tempDepth = numWords - (localIndex >= 0 ? 2 : 1); OP4( OVER, tempDepth); } @@ -1548,10 +1528,10 @@ TclCompileLsetCmd( * Emit the correct variety of 'lset' instruction. */ - if (parsePtr->numWords == 4) { + if (numWords == 4) { OP( LSET_LIST); } else { - OP4( LSET_FLAT, parsePtr->numWords - 1); + OP4( LSET_FLAT, numWords - 1); } /* @@ -1770,7 +1750,7 @@ TclCompileNamespaceUpvarCmd( DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr, *otherTokenPtr, *localTokenPtr; Tcl_LVTIndex localIndex; - int numWords, i; + int numWords = (int) parsePtr->numWords, i; if (envPtr->procPtr == NULL) { return TCL_ERROR; @@ -1780,7 +1760,6 @@ TclCompileNamespaceUpvarCmd( * Only compile [namespace upvar ...]: needs an even number of args, >=4 */ - numWords = (int)parsePtr->numWords; if ((numWords % 2) || (numWords < 4)) { return TCL_ERROR; } @@ -1829,10 +1808,10 @@ TclCompileNamespaceWhichCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ - Tcl_Token *tokenPtr, *opt; - int idx; + Tcl_Token *tokenPtr; + int numWords = (int) parsePtr->numWords, idx; - if ((int)parsePtr->numWords < 2 || (int)parsePtr->numWords > 3) { + if (numWords < 2 || numWords > 3) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -1843,13 +1822,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); @@ -1895,6 +1869,7 @@ TclCompileRegexpCmd( Tcl_Token *varTokenPtr; /* Pointer to the Tcl_Token representing the * parse of the RE or string. */ size_t len; + int numWords = (int) parsePtr->numWords; int i, nocase, exact, sawLast, simple; const char *str; @@ -1905,7 +1880,7 @@ TclCompileRegexpCmd( * regexp ?-nocase? ?--? {^staticString$} $var */ - if ((int)parsePtr->numWords < 3) { + if (numWords < 3) { return TCL_ERROR; } @@ -1920,7 +1895,7 @@ 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 (IS_TOKEN_LITERALLY(varTokenPtr, "--")) { sawLast++; @@ -1937,7 +1912,7 @@ TclCompileRegexpCmd( } } - if (((int)parsePtr->numWords - i) != 2) { + if (numWords - i != 2) { /* * We don't support capturing to variables. */ @@ -1989,7 +1964,7 @@ TclCompileRegexpCmd( } if (!simple) { - PUSH_TOKEN( varTokenPtr, (int)parsePtr->numWords - 2); + PUSH_TOKEN( varTokenPtr, numWords - 2); } /* @@ -1997,7 +1972,7 @@ TclCompileRegexpCmd( */ varTokenPtr = TokenAfter(varTokenPtr); - PUSH_TOKEN( varTokenPtr, (int)parsePtr->numWords - 1); + PUSH_TOKEN( varTokenPtr, numWords - 1); if (simple) { if (exact && !nocase) { @@ -2067,6 +2042,7 @@ TclCompileRegsubCmd( */ DefineLineInformation; /* TIP #280 */ + int numWords = (int) parsePtr->numWords; Tcl_Token *tokenPtr, *stringTokenPtr; Tcl_Obj *patternObj = NULL, *replacementObj = NULL; Tcl_DString pattern; @@ -2074,7 +2050,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; } @@ -2099,8 +2075,7 @@ 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); @@ -2109,7 +2084,7 @@ TclCompileRegsubCmd( if (!TclWordKnownAtCompileTime(tokenPtr, patternObj)) { goto done; } - } else if (parsePtr->numWords == 6) { + } else if (numWords == 6) { goto done; } @@ -2179,7 +2154,7 @@ TclCompileRegsubCmd( bytes = Tcl_DStringValue(&pattern) + 1; PushLiteral(envPtr, bytes, len); PUSH_OBJ( replacementObj); - PUSH_TOKEN( stringTokenPtr, (int)parsePtr->numWords - 2); + PUSH_TOKEN( stringTokenPtr, numWords - 2); OP( STR_MAP); done: @@ -2226,7 +2201,7 @@ TclCompileReturnCmd( */ int level, code, objc, status = TCL_OK; Tcl_Size size; - int numWords = parsePtr->numWords; + int numWords = (int) parsePtr->numWords; int explicitResult = (0 == (numWords % 2)); int numOptionWords = numWords - 1 - explicitResult; Tcl_Obj *returnOpts, **objv; @@ -2471,14 +2446,13 @@ TclCompileUpvarCmd( DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr, *otherTokenPtr, *localTokenPtr; Tcl_LVTIndex localIndex; - int numWords, i; + int numWords = (int) parsePtr->numWords, i; Tcl_Obj *objPtr; if (envPtr->procPtr == NULL) { return TCL_ERROR; } - numWords = (int) parsePtr->numWords; if (numWords < 3) { return TCL_ERROR; } @@ -2578,9 +2552,8 @@ TclCompileVariableCmd( DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr, *valueTokenPtr; Tcl_LVTIndex localIndex; - int numWords, i; + int numWords = (int) parsePtr->numWords, i; - numWords = parsePtr->numWords; if (numWords < 2) { return TCL_ERROR; } diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 5675099..b5cf6dd 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -137,8 +137,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. @@ -3118,13 +3117,11 @@ IssueTryClausesInstructions( OP( EQ); FWDJUMP( JUMP_FALSE, dontChangeOptions); + // Next bit isn't DICT_SET; alter which dict is in optionsVar + PUSH( "-during"); OP4( LOAD_SCALAR, optionsVar); - OP( SWAP); + OP( DICT_PUT); OP4( STORE_SCALAR, optionsVar); - OP( POP); - PUSH( "-during"); - OP( SWAP); - OP44( DICT_SET, 1, optionsVar); FWDLABEL( dontChangeOptions); OP( SWAP); @@ -3374,12 +3371,11 @@ IssueTryClausesFinallyInstructions( OP( EQ); FWDJUMP( JUMP_FALSE, noTrapError); - OP4( LOAD_SCALAR, optionsLocal); + // Next bit isn't DICT_SET; alter which dict is in optionsLocal PUSH( "-during"); - OP4( REVERSE, 3); + OP4( LOAD_SCALAR, optionsLocal); + OP( DICT_PUT); OP4( STORE_SCALAR, optionsLocal); - OP( POP); - OP44( DICT_SET, 1, optionsLocal); FWDJUMP( JUMP, trapError); FWDLABEL( noTrapError); @@ -3443,13 +3439,14 @@ IssueTryClausesFinallyInstructions( PUSH( "1"); OP( EQ); FWDJUMP( JUMP_FALSE, noFinalError); - OP4( LOAD_SCALAR, optionsLocal); + + // Next bit isn't DICT_SET; alter which dict is in optionsLocal PUSH( "-during"); - OP4( REVERSE, 3); + OP4( LOAD_SCALAR, optionsLocal); + OP( DICT_PUT); OP4( STORE_SCALAR, optionsLocal); OP( POP); - OP44( DICT_SET, 1, optionsLocal); - OP( POP); + // result FWDJUMP( JUMP, finalError); STKDELTA(+1); @@ -3525,9 +3522,7 @@ IssueTryFinallyInstructions( FWDJUMP( JUMP_FALSE, jumpSplice); PUSH( "-during"); OP4( OVER, 3); - // TODO: add [dict replace] support - OP4( LIST, 2); - OP( LIST_CONCAT); + OP( DICT_PUT); FWDLABEL( jumpSplice); OP4( REVERSE, 4); OP( POP); @@ -3652,8 +3647,7 @@ TclCompileUnsetCmd( * namespace qualifiers. */ - PushVarNameWord(interp, varTokenPtr, envPtr, 0, - &localIndex, &isScalar, i); + PushVarNameWord(varTokenPtr, 0, &localIndex, &isScalar, i); /* * Emit instructions to unset the variable. diff --git a/generic/tclCompUtils.h b/generic/tclCompUtils.h index 2c354e8..a4a1777 100644 --- a/generic/tclCompUtils.h +++ b/generic/tclCompUtils.h @@ -64,6 +64,13 @@ typedef int Tcl_AuxDataRef; SetLineInformation(index); \ TclCompileExprWords(interp, (tokenPtr), 1, envPtr); \ } while (0) +#define BODY(tokenPtr, index) \ + do { \ + SetLineInformation((index)); \ + TclCompileCmdWord(interp, \ + (tokenPtr)+1, (tokenPtr)->numComponents, \ + envPtr); \ + } while (0) #define BACKLABEL(var) \ (var)=CurrentOffset(envPtr) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 5d2027a..ea83da6 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -934,6 +934,11 @@ InstructionDesc const tclInstructionTable[] = { /* 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 */ {NULL, 0, 0, 0, {OPERAND_NONE}} }; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index cdbd3d2..e759d11 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -891,6 +891,7 @@ enum TclInstruction { INST_SWAP, INST_ERROR_PREFIX_EQ, INST_TCLOO_ID, + INST_DICT_PUT, /* The last opcode */ LAST_INST_OPCODE @@ -1733,18 +1734,6 @@ TclGetUInt4AtPtr(const unsigned char *p) { #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) - -/* * Convenience macro for use when compiling tokens to be pushed. The ANSI C * "prototype" for this macro is: * @@ -1834,7 +1823,7 @@ ExceptionRangeEnds( #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)) @@ -1880,9 +1869,9 @@ ExceptionRangeEnds( envPtr->clNext = eclPtr->next[(word)]; \ } while (0) -#define PushVarNameWord(i,v,e,f,l,sc,word) \ - SetLineInformation(word); \ - TclPushVarName(i,v,e,f,l,sc) +#define PushVarNameWord(varTokenPtr,flags,localIndexPtr,isScalarPtr,wordIndex) \ + SetLineInformation(wordIndex); \ + TclPushVarName(interp,varTokenPtr,envPtr,flags,localIndexPtr,isScalarPtr) #define ClearFailedCompile(envPtr) \ TclClearFailedCompile((envPtr), &lineInfo) diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 9c1734b..38c7c34 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -83,7 +83,7 @@ static const EnsembleImplMap implementationMap[] = { {"map", NULL, TclCompileDictMapCmd, DictMapNRCmd, NULL, 0 }, {"merge", DictMergeCmd, TclCompileDictMergeCmd, NULL, NULL, 0 }, {"remove", DictRemoveCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0 }, - {"replace", DictReplaceCmd, NULL, 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 }, diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 0a0e2ab..1dc3e60 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -272,16 +272,16 @@ VarHashCreateVar( pc += (pcAdjustment); \ switch (*pc) { \ case INST_JUMP_FALSE1: \ - NEXT_INST_F0(((condition)? 2 : TclGetInt1AtPtr(pc+1)), (cleanup)); \ + NEXT_INST_F0(((condition)? 2 : TclGetInt1AtPtr(pc + 1)), (cleanup)); \ break; \ case INST_JUMP_TRUE1: \ - NEXT_INST_F0(((condition)? TclGetInt1AtPtr(pc+1) : 2), (cleanup)); \ + NEXT_INST_F0(((condition)? TclGetInt1AtPtr(pc + 1) : 2), (cleanup)); \ break; \ case INST_JUMP_FALSE: \ - NEXT_INST_F0(((condition)? 5 : TclGetInt4AtPtr(pc+1)), (cleanup)); \ + NEXT_INST_F0(((condition)? 5 : TclGetInt4AtPtr(pc + 1)), (cleanup)); \ break; \ case INST_JUMP_TRUE: \ - NEXT_INST_F0(((condition)? TclGetInt4AtPtr(pc+1) : 5), (cleanup)); \ + NEXT_INST_F0(((condition)? TclGetInt4AtPtr(pc + 1) : 5), (cleanup)); \ break; \ default: \ if ((condition) < 0) { \ @@ -298,16 +298,16 @@ VarHashCreateVar( pc += (pcAdjustment); \ switch (*pc) { \ case INST_JUMP_FALSE1: \ - NEXT_INST_V(((condition)? 2 : TclGetInt1AtPtr(pc+1)), (cleanup), 0); \ + NEXT_INST_V(((condition)? 2 : TclGetInt1AtPtr(pc + 1)), (cleanup), 0); \ break; \ case INST_JUMP_TRUE1: \ - NEXT_INST_V(((condition)? TclGetInt1AtPtr(pc+1) : 2), (cleanup), 0); \ + NEXT_INST_V(((condition)? TclGetInt1AtPtr(pc + 1) : 2), (cleanup), 0); \ break; \ case INST_JUMP_FALSE: \ - NEXT_INST_V(((condition)? 5 : TclGetInt4AtPtr(pc+1)), (cleanup), 0); \ + NEXT_INST_V(((condition)? 5 : TclGetInt4AtPtr(pc + 1)), (cleanup), 0); \ break; \ case INST_JUMP_TRUE: \ - NEXT_INST_V(((condition)? TclGetInt4AtPtr(pc+1) : 5), (cleanup), 0); \ + NEXT_INST_V(((condition)? TclGetInt4AtPtr(pc + 1) : 5), (cleanup), 0); \ break; \ default: \ if ((condition) < 0) { \ @@ -837,7 +837,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); @@ -964,9 +964,9 @@ static inline int wordSkip( void *ptr) { - int mask = TCL_ALLOCALIGN-1; + int mask = TCL_ALLOCALIGN - 1; int base = (int)PTR2INT(ptr) & mask; - return (TCL_ALLOCALIGN - base)/(int)sizeof(Tcl_Obj *); + return (TCL_ALLOCALIGN - base) / (int)sizeof(Tcl_Obj *); } /* @@ -1041,7 +1041,7 @@ GrowEvaluationStack( /* * 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) { @@ -1095,7 +1095,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; @@ -1115,7 +1115,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; } /* @@ -1895,7 +1895,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) @@ -1939,7 +1939,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; @@ -2331,8 +2331,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. @@ -2493,11 +2493,11 @@ TEBCresume( case INST_TAILCALL1: DEPRECATED_OPCODE_MARK(INST_TAILCALL1); - opnd = TclGetUInt1AtPtr(pc+1); + opnd = TclGetUInt1AtPtr(pc + 1); goto doTailcall; case INST_TAILCALL: - opnd = TclGetUInt4AtPtr(pc+1); + opnd = TclGetUInt4AtPtr(pc + 1); doTailcall: if (!(iPtr->varFramePtr->isProcCallFrame & 1)) { @@ -2516,7 +2516,7 @@ TEBCresume( int i; TRACE(("%d [", opnd)); - for (i=opnd-1 ; i>=0 ; i--) { + for (i=opnd - 1 ; i>=0 ; i--) { TRACE_APPEND(("\"%.30s\"", O2S(OBJ_AT_DEPTH(i)))); if (i > 0) { TRACE_APPEND((" ")); @@ -2533,7 +2533,7 @@ TEBCresume( { Tcl_Obj *listPtr; - listPtr = Tcl_NewListObj(opnd, &OBJ_AT_DEPTH(opnd-1)); + listPtr = Tcl_NewListObj(opnd, &OBJ_AT_DEPTH(opnd - 1)); TclListObjSetElement(NULL, listPtr, 0, TclNewNamespaceObj( (Tcl_Namespace *) iPtr->varFramePtr->nsPtr)); if (iPtr->varFramePtr->tailcallPtr) { @@ -2578,14 +2578,14 @@ TEBCresume( case INST_PUSH1: DEPRECATED_OPCODE_MARK(INST_PUSH1); - objResultPtr = codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)]; - TRACE_WITH_OBJ(("%u => ", TclGetUInt1AtPtr(pc+1)), objResultPtr); + objResultPtr = codePtr->objArrayPtr[TclGetUInt1AtPtr(pc + 1)]; + TRACE_WITH_OBJ(("%u => ", TclGetUInt1AtPtr(pc + 1)), objResultPtr); NEXT_INST_F(2, 0, 1); break; case INST_PUSH: - objResultPtr = codePtr->objArrayPtr[TclGetUInt4AtPtr(pc+1)]; - TRACE_WITH_OBJ(("%u => ", TclGetUInt4AtPtr(pc+1)), objResultPtr); + objResultPtr = codePtr->objArrayPtr[TclGetUInt4AtPtr(pc + 1)]; + TRACE_WITH_OBJ(("%u => ", TclGetUInt4AtPtr(pc + 1)), objResultPtr); NEXT_INST_F(5, 0, 1); break; @@ -2603,7 +2603,7 @@ TEBCresume( break; case INST_OVER: - opnd = TclGetUInt4AtPtr(pc+1); + opnd = TclGetUInt4AtPtr(pc + 1); objResultPtr = OBJ_AT_DEPTH(opnd); TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); NEXT_INST_F(5, 0, 1); @@ -2639,9 +2639,9 @@ TEBCresume( break; case INST_STR_CONCAT1: - opnd = TclGetUInt1AtPtr(pc+1); + opnd = TclGetUInt1AtPtr(pc + 1); DECACHE_STACK_INFO(); - objResultPtr = TclStringCat(interp, opnd, &OBJ_AT_DEPTH(opnd-1), + objResultPtr = TclStringCat(interp, opnd, &OBJ_AT_DEPTH(opnd - 1), TCL_STRING_IN_PLACE); if (objResultPtr == NULL) { CACHE_STACK_INFO(); @@ -2660,7 +2660,7 @@ TEBCresume( * and then decrement their ref counts. */ - opnd = TclGetUInt4AtPtr(pc+1); + 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); @@ -2819,17 +2819,17 @@ TEBCresume( break; case INST_INVOKE_STK: - objc = TclGetUInt4AtPtr(pc+1); + objc = TclGetUInt4AtPtr(pc + 1); pcAdjustment = 5; goto doInvocation; case INST_INVOKE_STK1: DEPRECATED_OPCODE_MARK(INST_INVOKE_STK1); - objc = TclGetUInt1AtPtr(pc+1); + objc = TclGetUInt1AtPtr(pc + 1); pcAdjustment = 2; doInvocation: - objv = &OBJ_AT_DEPTH(objc-1); + objv = &OBJ_AT_DEPTH(objc - 1); cleanup = objc; #ifdef TCL_COMPILE_DEBUG @@ -2878,10 +2878,10 @@ TEBCresume( } case INST_INVOKE_REPLACE: - objc = TclGetUInt4AtPtr(pc+1); - opnd = TclGetUInt1AtPtr(pc+5); + objc = TclGetUInt4AtPtr(pc + 1); + opnd = 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 >= TCL_TRACE_BYTECODE_EXEC_COMMANDS) { @@ -2950,7 +2950,7 @@ TEBCresume( case INST_LOAD_SCALAR1: DEPRECATED_OPCODE_MARK(INST_LOAD_SCALAR1); - opnd = TclGetUInt1AtPtr(pc+1); + opnd = TclGetUInt1AtPtr(pc + 1); varPtr = LOCAL(opnd); while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; @@ -2973,7 +2973,7 @@ TEBCresume( case INST_LOAD_SCALAR: instLoadScalar: - opnd = TclGetUInt4AtPtr(pc+1); + opnd = TclGetUInt4AtPtr(pc + 1); varPtr = LOCAL(opnd); while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; @@ -2995,13 +2995,13 @@ TEBCresume( goto doCallPtrGetVar; case INST_LOAD_ARRAY: - opnd = TclGetUInt4AtPtr(pc+1); + opnd = TclGetUInt4AtPtr(pc + 1); pcAdjustment = 5; goto doLoadArray; case INST_LOAD_ARRAY1: DEPRECATED_OPCODE_MARK(INST_LOAD_ARRAY1); - opnd = TclGetUInt1AtPtr(pc+1); + opnd = TclGetUInt1AtPtr(pc + 1); pcAdjustment = 2; doLoadArray: @@ -3102,12 +3102,12 @@ TEBCresume( case INST_STORE_ARRAY1: DEPRECATED_OPCODE_MARK(INST_STORE_ARRAY1); - opnd = TclGetUInt1AtPtr(pc+1); + opnd = TclGetUInt1AtPtr(pc + 1); pcAdjustment = 2; goto doStoreArrayDirect; case INST_STORE_ARRAY: - opnd = TclGetUInt4AtPtr(pc+1); + opnd = TclGetUInt4AtPtr(pc + 1); pcAdjustment = 5; doStoreArrayDirect: @@ -3135,12 +3135,12 @@ TEBCresume( case INST_STORE_SCALAR1: DEPRECATED_OPCODE_MARK(INST_STORE_SCALAR1); - opnd = TclGetUInt1AtPtr(pc+1); + opnd = TclGetUInt1AtPtr(pc + 1); pcAdjustment = 2; goto doStoreScalarDirect; case INST_STORE_SCALAR: - opnd = TclGetUInt4AtPtr(pc+1); + opnd = TclGetUInt4AtPtr(pc + 1); pcAdjustment = 5; doStoreScalarDirect: @@ -3172,7 +3172,7 @@ TEBCresume( #ifndef TCL_COMPILE_DEBUG if (pc[pcAdjustment] == INST_POP) { tosPtr--; - NEXT_INST_F0((pcAdjustment+1), 0); + NEXT_INST_F0(pcAdjustment + 1, 0); } #else TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); @@ -3241,7 +3241,7 @@ TEBCresume( goto doCallPtrSetVar; case INST_LAPPEND_ARRAY: - opnd = TclGetUInt4AtPtr(pc+1); + opnd = TclGetUInt4AtPtr(pc + 1); pcAdjustment = 5; storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE | TCL_LIST_ELEMENT); @@ -3249,21 +3249,21 @@ TEBCresume( case INST_LAPPEND_ARRAY1: DEPRECATED_OPCODE_MARK(INST_LAPPEND_ARRAY1); - opnd = TclGetUInt1AtPtr(pc+1); + opnd = TclGetUInt1AtPtr(pc + 1); pcAdjustment = 2; storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE | TCL_LIST_ELEMENT); goto doStoreArray; case INST_APPEND_ARRAY: - opnd = TclGetUInt4AtPtr(pc+1); + opnd = TclGetUInt4AtPtr(pc + 1); pcAdjustment = 5; storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); goto doStoreArray; case INST_APPEND_ARRAY1: DEPRECATED_OPCODE_MARK(INST_APPEND_ARRAY1); - opnd = TclGetUInt1AtPtr(pc+1); + opnd = TclGetUInt1AtPtr(pc + 1); pcAdjustment = 2; storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); goto doStoreArray; @@ -3290,7 +3290,7 @@ TEBCresume( goto doCallPtrSetVar; case INST_LAPPEND_SCALAR: - opnd = TclGetUInt4AtPtr(pc+1); + opnd = TclGetUInt4AtPtr(pc + 1); pcAdjustment = 5; storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE | TCL_LIST_ELEMENT); @@ -3298,21 +3298,21 @@ TEBCresume( case INST_LAPPEND_SCALAR1: DEPRECATED_OPCODE_MARK(INST_LAPPEND_SCALAR1); - opnd = TclGetUInt1AtPtr(pc+1); + opnd = TclGetUInt1AtPtr(pc + 1); pcAdjustment = 2; storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE | TCL_LIST_ELEMENT); goto doStoreScalar; case INST_APPEND_SCALAR: - opnd = TclGetUInt4AtPtr(pc+1); + opnd = TclGetUInt4AtPtr(pc + 1); pcAdjustment = 5; storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); goto doStoreScalar; case INST_APPEND_SCALAR1: DEPRECATED_OPCODE_MARK(INST_APPEND_ARRAY1); - opnd = TclGetUInt1AtPtr(pc+1); + opnd = TclGetUInt1AtPtr(pc + 1); pcAdjustment = 2; storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); goto doStoreScalar; @@ -3339,14 +3339,14 @@ 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))); NEXT_INST_V(pcAdjustment, cleanup, 1); case INST_LAPPEND_LIST: - opnd = TclGetUInt4AtPtr(pc+1); + opnd = TclGetUInt4AtPtr(pc + 1); valuePtr = OBJ_AT_TOS; varPtr = LOCAL(opnd); cleanup = 1; @@ -3369,7 +3369,7 @@ TEBCresume( goto lappendListPtr; case INST_LAPPEND_LIST_ARRAY: - opnd = TclGetUInt4AtPtr(pc+1); + opnd = TclGetUInt4AtPtr(pc + 1); valuePtr = OBJ_AT_TOS; part1Ptr = NULL; part2Ptr = OBJ_UNDER_TOS; @@ -3536,7 +3536,7 @@ TEBCresume( case INST_INCR_ARRAY_STK: case INST_INCR_SCALAR_STK: case INST_INCR_STK: - opnd = TclGetUInt1AtPtr(pc+1); + opnd = TclGetUInt1AtPtr(pc + 1); incrPtr = POP_OBJECT(); switch (*pc) { case INST_INCR_SCALAR1: @@ -3554,7 +3554,7 @@ TEBCresume( case INST_INCR_SCALAR: case INST_INCR_ARRAY: - opnd = TclGetUInt4AtPtr(pc+1); + opnd = TclGetUInt4AtPtr(pc + 1); incrPtr = POP_OBJECT(); pcAdjustment = 5; switch (*pc) { @@ -3569,7 +3569,7 @@ TEBCresume( 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; @@ -3604,16 +3604,16 @@ TEBCresume( case INST_INCR_ARRAY1_IMM: DEPRECATED_OPCODE_MARK(INST_INCR_ARRAY1_IMM); - opnd = TclGetUInt1AtPtr(pc+1); - increment = TclGetInt1AtPtr(pc+2); + opnd = TclGetUInt1AtPtr(pc + 1); + increment = TclGetInt1AtPtr(pc + 2); TclNewIntObj(incrPtr, increment); Tcl_IncrRefCount(incrPtr); pcAdjustment = 3; goto doIncrArray; case INST_INCR_ARRAY_IMM: - opnd = TclGetUInt4AtPtr(pc+1); - increment = TclGetInt1AtPtr(pc+5); + opnd = TclGetUInt4AtPtr(pc + 1); + increment = TclGetInt1AtPtr(pc + 5); TclNewIntObj(incrPtr, increment); Tcl_IncrRefCount(incrPtr); pcAdjustment = 6; @@ -3638,13 +3638,13 @@ TEBCresume( case INST_INCR_SCALAR1_IMM: DEPRECATED_OPCODE_MARK(INST_INCR_SCALAR1_IMM); - opnd = TclGetUInt1AtPtr(pc+1); - increment = TclGetInt1AtPtr(pc+2); + opnd = TclGetUInt1AtPtr(pc + 1); + increment = TclGetInt1AtPtr(pc + 2); pcAdjustment = 3; goto doIncrScalarImm; case INST_INCR_SCALAR_IMM: - opnd = TclGetUInt4AtPtr(pc+1); - increment = TclGetInt1AtPtr(pc+5); + opnd = TclGetUInt4AtPtr(pc + 1); + increment = TclGetInt1AtPtr(pc + 5); pcAdjustment = 6; doIncrScalarImm: cleanup = 0; @@ -3770,7 +3770,7 @@ TEBCresume( TRACE_APPEND(("%.30s\n", O2S(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); @@ -3785,7 +3785,7 @@ TEBCresume( case INST_EXIST_SCALAR: cleanup = 0; pcAdjustment = 5; - opnd = TclGetUInt4AtPtr(pc+1); + opnd = TclGetUInt4AtPtr(pc + 1); varPtr = LOCAL(opnd); while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; @@ -3806,7 +3806,7 @@ TEBCresume( case INST_EXIST_ARRAY: cleanup = 1; pcAdjustment = 5; - opnd = TclGetUInt4AtPtr(pc+1); + opnd = TclGetUInt4AtPtr(pc + 1); part2Ptr = OBJ_AT_TOS; arrayPtr = LOCAL(opnd); while (TclIsVarLink(arrayPtr)) { @@ -3887,8 +3887,8 @@ TEBCresume( int flags; case INST_UNSET_SCALAR: - flags = TclGetUInt1AtPtr(pc+1) ? TCL_LEAVE_ERR_MSG : 0; - opnd = TclGetUInt4AtPtr(pc+2); + flags = TclGetUInt1AtPtr(pc + 1) ? TCL_LEAVE_ERR_MSG : 0; + opnd = TclGetUInt4AtPtr(pc + 2); varPtr = LOCAL(opnd); while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; @@ -3920,8 +3920,8 @@ TEBCresume( 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; + opnd = TclGetUInt4AtPtr(pc + 2); part2Ptr = OBJ_AT_TOS; arrayPtr = LOCAL(opnd); while (TclIsVarLink(arrayPtr)) { @@ -3973,7 +3973,7 @@ TEBCresume( 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 */ @@ -3982,7 +3982,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 */ @@ -4015,7 +4015,7 @@ TEBCresume( const char *msgPart; case INST_CONST_IMM: - opnd = TclGetUInt4AtPtr(pc+1); + opnd = TclGetUInt4AtPtr(pc + 1); pcAdjustment = 5; cleanup = 1; part1Ptr = NULL; @@ -4084,7 +4084,7 @@ TEBCresume( */ case INST_ARRAY_EXISTS_IMM: - opnd = TclGetUInt4AtPtr(pc+1); + opnd = TclGetUInt4AtPtr(pc + 1); pcAdjustment = 5; cleanup = 0; part1Ptr = NULL; @@ -4120,7 +4120,7 @@ TEBCresume( NEXT_INST_V(pcAdjustment, cleanup, 1); case INST_ARRAY_MAKE_IMM: - opnd = TclGetUInt4AtPtr(pc+1); + opnd = TclGetUInt4AtPtr(pc + 1); pcAdjustment = 5; cleanup = 0; part1Ptr = NULL; @@ -4180,7 +4180,7 @@ TEBCresume( Namespace *savedNsPtr; case INST_UPVAR: - TRACE(("%d %.30s %.30s => ", TclGetInt4AtPtr(pc+1), + TRACE(("%d %.30s %.30s => ", TclGetInt4AtPtr(pc + 1), O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS))); if (TclObjGetFrame(interp, OBJ_UNDER_TOS, &framePtr) == -1) { @@ -4205,7 +4205,7 @@ TEBCresume( goto doLinkVars; case INST_NSUPVAR: - TRACE(("%d %.30s %.30s => ", TclGetInt4AtPtr(pc+1), + TRACE(("%d %.30s %.30s => ", TclGetInt4AtPtr(pc + 1), O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS))); if (TclGetNamespaceFromObj(interp, OBJ_UNDER_TOS, &nsPtr) != TCL_OK) { TRACE_ERROR(interp); @@ -4229,7 +4229,7 @@ TEBCresume( goto doLinkVars; case INST_VARIABLE: - TRACE(("%d, %.30s => ", TclGetInt4AtPtr(pc+1), O2S(OBJ_AT_TOS))); + TRACE(("%d, %.30s => ", TclGetInt4AtPtr(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); @@ -4252,7 +4252,7 @@ TEBCresume( * if there are no errors; otherwise, let it handle the case. */ - opnd = TclGetInt4AtPtr(pc+1); + opnd = TclGetInt4AtPtr(pc + 1); varPtr = LOCAL(opnd); if ((varPtr != otherPtr) && !TclIsVarTraced(varPtr) && (TclIsVarUndefined(varPtr) || TclIsVarLink(varPtr))) { @@ -4302,13 +4302,13 @@ TEBCresume( case INST_JUMP1: DEPRECATED_OPCODE_MARK(INST_JUMP1); - opnd = TclGetInt1AtPtr(pc+1); + opnd = TclGetInt1AtPtr(pc + 1); TRACE(("%d => new pc %" TCL_Z_MODIFIER "u\n", opnd, (size_t)(pc + opnd - codePtr->codeStart))); NEXT_INST_F0(opnd, 0); case INST_JUMP: - opnd = TclGetInt4AtPtr(pc+1); + opnd = TclGetInt4AtPtr(pc + 1); TRACE(("%d => new pc %" TCL_Z_MODIFIER "u\n", opnd, (size_t)(pc + opnd - codePtr->codeStart))); NEXT_INST_F0(opnd, 0); @@ -4320,24 +4320,24 @@ TEBCresume( * going to take. */ case INST_JUMP_FALSE1: DEPRECATED_OPCODE_MARK(INST_JUMP_FALSE1); - jmpOffset[0] = TclGetInt1AtPtr(pc+1); + jmpOffset[0] = TclGetInt1AtPtr(pc + 1); jmpOffset[1] = 2; 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); goto doCondJump; case INST_JUMP_FALSE: - jmpOffset[0] = TclGetInt4AtPtr(pc+1); /* FALSE offset */ + jmpOffset[0] = TclGetInt4AtPtr(pc + 1); /* FALSE offset */ jmpOffset[1] = 5; /* TRUE offset */ goto doCondJump; case INST_JUMP_TRUE: jmpOffset[0] = 5; - jmpOffset[1] = TclGetInt4AtPtr(pc+1); + jmpOffset[1] = TclGetInt4AtPtr(pc + 1); doCondJump: valuePtr = OBJ_AT_TOS; @@ -4381,7 +4381,7 @@ TEBCresume( * instr if lookup fails. */ - opnd = TclGetInt4AtPtr(pc+1); + opnd = TclGetInt4AtPtr(pc + 1); jtPtr = (JumptableInfo *) codePtr->auxDataArrayPtr[opnd].clientData; TRACE(("%d \"%.20s\" => ", opnd, O2S(OBJ_AT_TOS))); hPtr = Tcl_FindHashEntry(&jtPtr->hashTable, TclGetString(OBJ_AT_TOS)); @@ -4533,11 +4533,11 @@ TEBCresume( case INST_TCLOO_NEXT_CLASS1: DEPRECATED_OPCODE_MARK(INST_TCLOO_NEXT_CLASS1); - opnd = TclGetUInt1AtPtr(pc+1); + opnd = TclGetUInt1AtPtr(pc + 1); pcAdjustment = 2; goto invokeNextClass; case INST_TCLOO_NEXT_CLASS: - opnd = TclGetUInt4AtPtr(pc+1); + opnd = TclGetUInt4AtPtr(pc + 1); pcAdjustment = 5; invokeNextClass: framePtr = iPtr->varFramePtr; @@ -4639,11 +4639,11 @@ TEBCresume( case INST_TCLOO_NEXT1: DEPRECATED_OPCODE_MARK(INST_TCLOO_NEXT1); - opnd = TclGetUInt1AtPtr(pc+1); + opnd = TclGetUInt1AtPtr(pc + 1); pcAdjustment = 2; goto invokeNext; case INST_TCLOO_NEXT: - opnd = TclGetUInt4AtPtr(pc+1); + opnd = TclGetUInt4AtPtr(pc + 1); pcAdjustment = 5; invokeNext: objv = &OBJ_AT_DEPTH(opnd - 1); @@ -4799,8 +4799,8 @@ TEBCresume( * decrement their ref counts. */ - opnd = TclGetUInt4AtPtr(pc+1); - objResultPtr = Tcl_NewListObj(opnd, &OBJ_AT_DEPTH(opnd-1)); + 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); @@ -4823,7 +4823,7 @@ TEBCresume( if (TclObjTypeHasProc(valuePtr, indexProc)) { DECACHE_STACK_INFO(); length = TclObjTypeLength(valuePtr); - if (TclGetIntForIndexM(interp, value2Ptr, length-1, &index)!=TCL_OK) { + if (TclGetIntForIndexM(interp, value2Ptr, length - 1, &index)!=TCL_OK) { CACHE_STACK_INFO(); TRACE_ERROR(interp); goto gotError; @@ -4864,7 +4864,7 @@ TEBCresume( Tcl_IncrRefCount(indexListPtr); DECACHE_STACK_INFO(); - code = TclGetIntForIndexM(interp, indexListPtr, objc-1, &index); + code = TclGetIntForIndexM(interp, indexListPtr, objc - 1, &index); TclDecrRefCount(indexListPtr); CACHE_STACK_INFO(); if (code == TCL_OK) { @@ -4902,7 +4902,7 @@ TEBCresume( */ valuePtr = OBJ_AT_TOS; - opnd = TclGetInt4AtPtr(pc+1); + opnd = TclGetInt4AtPtr(pc + 1); TRACE(("\"%.30s\" %d => ", O2S(valuePtr), opnd)); /* @@ -4915,7 +4915,7 @@ TEBCresume( length = TclObjTypeLength(valuePtr); /* Decode end-offset index values. */ - index = TclIndexDecode(opnd, length-1); + index = TclIndexDecode(opnd, length - 1); if (index >= 0 && index < length) { /* Compute value @ index */ @@ -4962,8 +4962,8 @@ TEBCresume( * Determine the count of index args. */ - opnd = TclGetUInt4AtPtr(pc+1); - numIndices = opnd-1; + opnd = TclGetUInt4AtPtr(pc + 1); + numIndices = opnd - 1; /* * Do the 'lindex' operation. @@ -5027,7 +5027,7 @@ TEBCresume( */ CACHE_STACK_INFO(); TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); - NEXT_INST_V(5, numIndices+1, -1); + NEXT_INST_V(5, numIndices + 1, -1); case INST_LSET_LIST: /* 'lset' with 4 args */ /* @@ -5074,10 +5074,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))); + fromIdx = TclGetInt4AtPtr(pc + 1); + toIdx = TclGetInt4AtPtr(pc + 5); + TRACE(("\"%.30s\" %d %d => ", O2S(valuePtr), (int)fromIdx, (int)toIdx)); /* * Get the length of the list, making sure that it really is a list @@ -5260,7 +5259,7 @@ TEBCresume( flags = TclGetInt1AtPtr(pc + 5); /* Stack: ... listobj index1 ?index2? new1 ... newN */ - valuePtr = OBJ_AT_DEPTH(opnd-1); + valuePtr = OBJ_AT_DEPTH(opnd - 1); /* haveSecondIndex==0 => pure insert */ haveSecondIndex = (flags & TCL_LREPLACE4_SINGLE_INDEX) == 0; @@ -5464,7 +5463,7 @@ TEBCresume( slength = Tcl_GetCharLength(valuePtr); DECACHE_STACK_INFO(); - if (TclGetIntForIndexM(interp, value2Ptr, slength-1, &index)!=TCL_OK) { + if (TclGetIntForIndexM(interp, value2Ptr, slength - 1, &index)!=TCL_OK) { CACHE_STACK_INFO(); TRACE_ERROR(interp); goto gotError; @@ -5478,7 +5477,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); @@ -5527,10 +5526,10 @@ TEBCresume( case INST_STR_RANGE_IMM: valuePtr = OBJ_AT_TOS; - fromIdx = TclGetInt4AtPtr(pc+1); - toIdx = TclGetInt4AtPtr(pc+5); + fromIdx = TclGetInt4AtPtr(pc + 1); + toIdx = TclGetInt4AtPtr(pc + 5); slength = Tcl_GetCharLength(valuePtr); - TRACE(("\"%.20s\" %d %d => ", O2S(valuePtr), (int)(fromIdx), (int)(toIdx))); + TRACE(("\"%.20s\" %d %d => ", O2S(valuePtr), (int)fromIdx, (int)toIdx)); /* Every range of an empty value is an empty value */ if (slength == 0) { @@ -5687,7 +5686,7 @@ TEBCresume( NEXT_INST_F(1, 2, 1); case INST_STR_CLASS: - opnd = TclGetInt1AtPtr(pc+1); + opnd = TclGetInt1AtPtr(pc + 1); valuePtr = OBJ_AT_TOS; TRACE(("%s \"%.30s\" => ", tclStringClassTable[opnd].name, O2S(valuePtr))); @@ -5709,7 +5708,7 @@ TEBCresume( } case INST_STR_MATCH: - nocase = TclGetInt1AtPtr(pc+1); + nocase = TclGetInt1AtPtr(pc + 1); valuePtr = OBJ_AT_TOS; /* String */ value2Ptr = OBJ_UNDER_TOS; /* Pattern */ @@ -6573,7 +6572,7 @@ TEBCresume( * corresponding Tcl_Objs to the stack. */ - opnd = TclGetUInt4AtPtr(pc+1); + opnd = TclGetUInt4AtPtr(pc + 1); infoPtr = (ForeachInfo *)codePtr->auxDataArrayPtr[opnd].clientData; numLists = infoPtr->numLists; TRACE(("%u => ", opnd)); @@ -6583,7 +6582,7 @@ TEBCresume( */ iterMax = 0; - listTmpDepth = numLists-1; + listTmpDepth = numLists - 1; for (i = 0; i < numLists; i++) { varListPtr = infoPtr->varLists[i]; numVars = varListPtr->numVars; @@ -6762,7 +6761,7 @@ TEBCresume( 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: /* @@ -6795,7 +6794,7 @@ 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), + TclGetUInt4AtPtr(pc + 1), (catchTop - initCatchTop - 1), CURR_DEPTH)); NEXT_INST_F0(5, 0); break; @@ -6851,8 +6850,8 @@ 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_F0(2*code-1, 1); + TRACE(("\"%s\" => jump offset %d\n", O2S(OBJ_AT_TOS), 2*code - 1)); + NEXT_INST_F0(2*code - 1, 1); } case INST_RETURN_CODE_BRANCH: { @@ -6867,8 +6866,8 @@ TEBCresume( if (code < TCL_ERROR || code > TCL_CONTINUE) { code = TCL_CONTINUE + 1; } - TRACE(("\"%s\" => jump offset %d\n", O2S(OBJ_AT_TOS), 5*code-4)); - NEXT_INST_F0(5*code-4, 1); + TRACE(("\"%s\" => jump offset %d\n", O2S(OBJ_AT_TOS), 5*code - 4)); + NEXT_INST_F0(5*code - 4, 1); } case INST_ERROR_PREFIX_EQ: { @@ -6944,12 +6943,12 @@ TEBCresume( case INST_DICT_EXISTS: { int found; - opnd = TclGetUInt4AtPtr(pc+1); + 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); + dictPtr = TclTraceDictPath(NULL, dictPtr, opnd - 1, + &OBJ_AT_DEPTH(opnd - 1), DICT_PATH_EXISTS); if (dictPtr == NULL || dictPtr == DICT_PATH_NON_EXISTENT) { found = 0; goto afterDictExists; @@ -6971,27 +6970,45 @@ TEBCresume( * someone doing something else). */ - JUMP_PEEPHOLE_V(found, 5, opnd+1); + JUMP_PEEPHOLE_V(found, 5, opnd + 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) { + TRACE_ERROR(interp); + goto gotError; + } + TRACE_APPEND(("\"%.30s\"\n", O2S(dictPtr))); + if (allocateDict) { + objResultPtr = dictPtr; + NEXT_INST_V(1, 3, 1); + } else { + NEXT_INST_F0(1, 2); + } case INST_DICT_GET: - opnd = TclGetUInt4AtPtr(pc+1); + 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); + dictPtr = TclTraceDictPath(interp, dictPtr, opnd - 1, + &OBJ_AT_DEPTH(opnd - 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", + O2S(OBJ_AT_DEPTH(opnd)), 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)))); + O2S(OBJ_AT_TOS), O2S(Tcl_GetObjResult(interp)))); goto gotError; } if (!objResultPtr) { @@ -7002,23 +7019,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", + O2S(OBJ_AT_TOS), O2S(Tcl_GetObjResult(interp)))); goto gotError; } TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_V(5, opnd+1, 1); + NEXT_INST_V(5, opnd + 1, 1); case INST_DICT_GET_DEF: - opnd = TclGetUInt4AtPtr(pc+1); + opnd = TclGetUInt4AtPtr(pc + 1); TRACE(("%u => ", opnd)); - dictPtr = OBJ_AT_DEPTH(opnd+1); + dictPtr = OBJ_AT_DEPTH(opnd + 1); if (opnd > 1) { - dictPtr = TclTraceDictPath(interp, dictPtr, opnd-1, + dictPtr = TclTraceDictPath(interp, dictPtr, opnd - 1, &OBJ_AT_DEPTH(opnd), 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", + O2S(OBJ_AT_DEPTH(opnd + 1)), + Tcl_GetObjResult(interp))); goto gotError; } else if (dictPtr == DICT_PATH_NON_EXISTENT) { goto dictGetDefUseDefault; @@ -7034,13 +7052,13 @@ TEBCresume( objResultPtr = OBJ_AT_TOS; } TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_V(5, opnd+2, 1); + NEXT_INST_V(5, opnd + 2, 1); case INST_DICT_SET: case INST_DICT_UNSET: case INST_DICT_INCR_IMM: - opnd = TclGetUInt4AtPtr(pc+1); - opnd2 = TclGetUInt4AtPtr(pc+5); + opnd = TclGetUInt4AtPtr(pc + 1); + opnd2 = TclGetUInt4AtPtr(pc + 5); varPtr = LOCAL(opnd2); while (TclIsVarLink(varPtr)) { @@ -7073,7 +7091,7 @@ TEBCresume( break; case INST_DICT_INCR_IMM: cleanup = 1; - opnd = TclGetInt4AtPtr(pc+1); + opnd = TclGetInt4AtPtr(pc + 1); result = Tcl_DictObjGet(interp, dictPtr, OBJ_AT_TOS, &valuePtr); if (result != TCL_OK) { break; @@ -7097,7 +7115,7 @@ TEBCresume( case INST_DICT_UNSET: cleanup = opnd; result = Tcl_DictObjRemoveKeyList(interp, dictPtr, opnd, - &OBJ_AT_DEPTH(opnd-1)); + &OBJ_AT_DEPTH(opnd - 1)); break; default: cleanup = 0; /* stop compiler warning */ @@ -7145,7 +7163,7 @@ TEBCresume( case INST_DICT_APPEND: case INST_DICT_LAPPEND: - opnd = TclGetUInt4AtPtr(pc+1); + opnd = TclGetUInt4AtPtr(pc + 1); varPtr = LOCAL(opnd); while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; @@ -7283,7 +7301,7 @@ TEBCresume( NEXT_INST_F(5, 2, 1); case INST_DICT_FIRST: - opnd = TclGetUInt4AtPtr(pc+1); + opnd = TclGetUInt4AtPtr(pc + 1); TRACE(("%u => ", opnd)); dictPtr = POP_OBJECT(); searchPtr = (Tcl_DictSearch *)Tcl_Alloc(sizeof(Tcl_DictSearch)); @@ -7319,7 +7337,7 @@ TEBCresume( goto pushDictIteratorResult; case INST_DICT_NEXT: - opnd = TclGetUInt4AtPtr(pc+1); + opnd = TclGetUInt4AtPtr(pc + 1); TRACE(("%u => ", opnd)); statePtr = (*LOCAL(opnd)).value.objPtr; { @@ -7355,8 +7373,8 @@ TEBCresume( JUMP_PEEPHOLE_F(done, 5, 0); case INST_DICT_UPDATE_START: - opnd = TclGetUInt4AtPtr(pc+1); - opnd2 = TclGetUInt4AtPtr(pc+5); + opnd = TclGetUInt4AtPtr(pc + 1); + opnd2 = TclGetUInt4AtPtr(pc + 5); TRACE(("%u => ", opnd)); varPtr = LOCAL(opnd); duiPtr = (DictUpdateInfo *)codePtr->auxDataArrayPtr[opnd2].clientData; @@ -7415,8 +7433,8 @@ TEBCresume( NEXT_INST_F0(9, 0); case INST_DICT_UPDATE_END: - opnd = TclGetUInt4AtPtr(pc+1); - opnd2 = TclGetUInt4AtPtr(pc+5); + opnd = TclGetUInt4AtPtr(pc + 1); + opnd2 = TclGetUInt4AtPtr(pc + 5); TRACE(("%u => ", opnd)); varPtr = LOCAL(opnd); duiPtr = (DictUpdateInfo *)codePtr->auxDataArrayPtr[opnd2].clientData; @@ -7538,7 +7556,7 @@ TEBCresume( NEXT_INST_F0(1, 2); case INST_DICT_RECOMBINE_IMM: - opnd = TclGetUInt4AtPtr(pc+1); + opnd = TclGetUInt4AtPtr(pc + 1); listPtr = OBJ_UNDER_TOS; keysPtr = OBJ_AT_TOS; varPtr = LOCAL(opnd); @@ -7572,7 +7590,7 @@ TEBCresume( case INST_CLOCK_READ: { /* Read the wall clock */ Tcl_WideInt wval; Tcl_Time now; - switch (TclGetUInt1AtPtr(pc+1)) { + switch (TclGetUInt1AtPtr(pc + 1)) { case 0: /* clicks */ #ifdef TCL_WIDE_CLICKS wval = TclpGetWideClicks(); @@ -7628,11 +7646,11 @@ TEBCresume( #ifdef TCL_COMPILE_DEBUG switch (*pc) { case INST_INVOKE_STK1: - opnd = TclGetUInt1AtPtr(pc+1); + opnd = TclGetUInt1AtPtr(pc + 1); TRACE(("%u => ... after \"%.20s\": ", opnd, cmdNameBuf)); break; case INST_INVOKE_STK: - opnd = TclGetUInt4AtPtr(pc+1); + opnd = TclGetUInt4AtPtr(pc + 1); TRACE(("%u => ... after \"%.20s\": ", opnd, cmdNameBuf)); break; case INST_EVAL_STK: @@ -7937,8 +7955,8 @@ TEBCresume( codePtr->flags |= TCL_BYTECODE_RECOMPILE; bytes = GetSrcInfoForPc(pc, codePtr, &xxx1length, NULL, NULL); - opnd = TclGetUInt4AtPtr(pc+1); - pc += (opnd-1); + opnd = TclGetUInt4AtPtr(pc + 1); + pc += (opnd - 1); assert(bytes); PUSH_OBJECT(Tcl_NewStringObj(bytes, xxx1length)); goto instEvalStk; @@ -9934,13 +9952,13 @@ 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); } } } @@ -10044,7 +10062,7 @@ 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", decadeHigh, Percent(sum, statsPtr->numLiteralsCreated)); @@ -10077,7 +10095,7 @@ 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", decadeHigh, Percent(sum, statsPtr->numCompilations)); @@ -10101,7 +10119,7 @@ EvalStatsCmd( maxSizeDecade = i; sum = 0; for (ui = minSizeDecade; ui <= maxSizeDecade; i++) { - 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", decadeHigh, Percent(sum, statsPtr->numCompilations)); @@ -10125,7 +10143,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)); diff --git a/generic/tclInt.h b/generic/tclInt.h index ea059c2..182d417 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3808,6 +3808,7 @@ MODULE_SCOPE CompileProc TclCompileDictIncrCmd; MODULE_SCOPE CompileProc TclCompileDictLappendCmd; MODULE_SCOPE CompileProc TclCompileDictMapCmd; MODULE_SCOPE CompileProc TclCompileDictMergeCmd; +MODULE_SCOPE CompileProc TclCompileDictReplaceCmd; MODULE_SCOPE CompileProc TclCompileDictSetCmd; MODULE_SCOPE CompileProc TclCompileDictUnsetCmd; MODULE_SCOPE CompileProc TclCompileDictUpdateCmd; -- cgit v0.12 From a8fc23ad3082f9c2b2729c15b0e21056be501432 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 15 Apr 2025 07:11:51 +0000 Subject: Fix more -Wconversion warnings --- generic/tclBasic.c | 6 +++--- generic/tclDictObj.c | 15 +++++++++------ generic/tclInt.h | 28 ++++++++++++++-------------- generic/tclParse.c | 10 +++++----- generic/tclResult.c | 2 +- generic/tclTrace.c | 14 +++++++------- generic/tclVar.c | 36 ++++++++++++++++++++---------------- 7 files changed, 59 insertions(+), 52 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 3cbf091..317f6de 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -2734,7 +2734,7 @@ 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 @@ -5671,7 +5671,7 @@ void TclAdvanceContinuations( Tcl_Size *line, Tcl_Size **clNextPtrPtr, - int loc) + Tcl_Size loc) { /* * Track the invisible continuation lines embedded in a script, if any. @@ -7715,7 +7715,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. diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 9c1734b..892ba87 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -546,7 +546,9 @@ UpdateStringOfDict( dst = Tcl_InitStringRep(dictPtr, NULL, bytesNeeded - 1); TclOOM(dst, bytesNeeded); for (i=0,cPtr=dict->entryChainHead; inextPtr) { - 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]); @@ -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 ...?"); @@ -3855,10 +3858,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/tclInt.h b/generic/tclInt.h index e266f62..16dcac9 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2168,7 +2168,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 @@ -3229,7 +3229,7 @@ struct Tcl_LoadHandle_ { */ MODULE_SCOPE void TclAdvanceContinuations(Tcl_Size *line, Tcl_Size **next, - int loc); + Tcl_Size loc); MODULE_SCOPE void TclAdvanceLines(Tcl_Size *line, const char *start, const char *end); MODULE_SCOPE void TclAppendBytesToByteArray(Tcl_Obj *objPtr, @@ -3260,7 +3260,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); @@ -3440,7 +3440,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); @@ -3449,13 +3449,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, @@ -3690,7 +3690,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[]); @@ -3981,25 +3981,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); 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); @@ -4010,7 +4010,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. @@ -4496,7 +4496,7 @@ MODULE_SCOPE const TclFileAttrProcs tclpFileAttrProcs[]; do { \ Tcl_Obj *bignumObj = (objPtr); \ int bignumPayload = \ - PTR2INT(bignumObj->internalRep.twoPtrValue.ptr2); \ + (int)PTR2INT(bignumObj->internalRep.twoPtrValue.ptr2); \ if (bignumPayload == -1) { \ (bignum) = *((mp_int *) bignumObj->internalRep.twoPtrValue.ptr1); \ } else { \ diff --git a/generic/tclParse.c b/generic/tclParse.c index 3879733..872ccb5 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); /* @@ -724,7 +724,7 @@ TclParseAllWhiteSpace( *---------------------------------------------------------------------- */ -int +Tcl_Size ParseHex( const char *src, /* First character to parse. */ Tcl_Size numBytes, /* Max number of byes to scan */ @@ -779,7 +779,7 @@ ParseHex( *---------------------------------------------------------------------- */ -int +Tcl_Size TclParseBackslash( const char *src, /* Points to the backslash character of a * backslash sequence. */ @@ -1329,7 +1329,7 @@ Tcl_ParseVarName( { Tcl_Token *tokenPtr; const char *src; - int varIndex; + Tcl_Size varIndex; unsigned array; if (numBytes < 0 && start) { @@ -2166,7 +2166,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/tclResult.c b/generic/tclResult.c index 2e7d378..8890079 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -807,7 +807,7 @@ TclProcessReturn( 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/tclTrace.c b/generic/tclTrace.c index f1d83e7..71572e0 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -1995,10 +1995,10 @@ 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 @@ -2187,8 +2187,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; @@ -2393,7 +2393,7 @@ TclCheckArrayTraces( Var *varPtr, Var *arrayPtr, Tcl_Obj *name, - int index) + Tcl_Size index) { int code = TCL_OK; @@ -2446,7 +2446,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. */ { @@ -2528,7 +2528,7 @@ TclCallVarTraces( } while (*p != '\0'); p--; if (*p == ')') { - int offset = (openParen - part1); + Tcl_Size offset = (openParen - part1); char *newPart1; Tcl_DStringInit(&nameCopy); diff --git a/generic/tclVar.c b/generic/tclVar.c index a94744f..dec319e 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -191,7 +191,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 +201,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] @@ -607,7 +607,8 @@ TclObjLookupVarEx( Var *varPtr; /* Points to the variable's in-frame Var * structure. */ const char *errMsg = NULL; - int index, parsed = 0; + int index; + int parsed = 0; Tcl_Size localIndex; Tcl_Obj *namePtr, *arrayPtr, *elem; @@ -1072,7 +1073,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; @@ -1384,7 +1385,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 +1913,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 +2230,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 +2465,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. */ { @@ -2550,7 +2551,7 @@ UnsetVarStruct( Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags, - int index) + Tcl_Size index) { Var dummyVar; int traced = TclIsVarTraced(varPtr) @@ -2735,7 +2736,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) { @@ -4486,7 +4488,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; @@ -4944,7 +4946,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. @@ -5048,7 +5051,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 Date: Tue, 15 Apr 2025 09:10:23 +0000 Subject: Missing TCL_NO_DEPRECATED --- generic/tcl.h | 6 +++--- generic/tclClockFmt.c | 2 +- generic/tclExecute.c | 13 ++++--------- generic/tclHash.c | 4 ++++ 4 files changed, 12 insertions(+), 13 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index cb927c0..7ccfe4a 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2521,8 +2521,8 @@ static inline void * TclDbPanicIfNull( void *entry, const char *fn, - const char *file, - int line) + const char *file, + int line) { if (!entry) { Tcl_Panic("%s: Memory overflow in file %s:%d", fn, file, line); @@ -2537,7 +2537,7 @@ TclDbPanicIfNull( static inline void * TclPanicIfNull( void *entry, - const char *fn) + const char *fn) { if (!entry) { Tcl_Panic("%s: Memory overflow", fn); diff --git a/generic/tclClockFmt.c b/generic/tclClockFmt.c index beec218..880a1ad 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/tclExecute.c b/generic/tclExecute.c index a1f2056..f78efe2 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -155,22 +155,17 @@ typedef struct { ((Var *) ((char *)hPtr - offsetof(VarInHash, entry))) static inline Var * -VarHashCreateVar( +VarHashFindVar( TclVarHashTable *tablePtr, - Tcl_Obj *key, - int *newPtr) + Tcl_Obj *key) { - Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(&tablePtr->table, - key, newPtr); - + Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&tablePtr->table, + key); if (!hPtr) { return NULL; } return VarHashGetValue(hPtr); } - -#define VarHashFindVar(tablePtr, key) \ - VarHashCreateVar((tablePtr), (key), TCL_HASH_FIND) /* * The new macro for ending an instruction; note that a reasonable C-optimiser diff --git a/generic/tclHash.c b/generic/tclHash.c index 1b4d644..f5c37c4 100644 --- a/generic/tclHash.c +++ b/generic/tclHash.c @@ -53,7 +53,9 @@ 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 = { @@ -204,6 +206,7 @@ Tcl_InitCustomHashTable( *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED static Tcl_HashEntry * FindHashEntry( Tcl_HashTable *tablePtr, /* Table in which to lookup entry. */ @@ -211,6 +214,7 @@ FindHashEntry( { return tablePtr->createProc(tablePtr, key, TCL_HASH_FIND); } +#endif /* *---------------------------------------------------------------------- -- cgit v0.12 From 23e30002093394cf9f38512d97c320b9813b76a0 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 15 Apr 2025 10:40:42 +0000 Subject: Testcase for TIP #716 --- tests/cmdAH.test | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/tests/cmdAH.test b/tests/cmdAH.test index 028fbf1..50e49e8 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -1268,7 +1268,7 @@ test cmdAH-15.1 {Tcl_FileObjCmd} -constraints testsetplatform -body { catch {testsetplatform $platform} # readable -set gorpfile [makeFile abcde gorp.file] +set gorpfile [makeFile abcde górp.file] set dirfile [makeDirectory dir.file] test cmdAH-16.1 {Tcl_FileObjCmd: readable} { -returnCodes error @@ -1311,7 +1311,7 @@ test cmdAH-17.3 {Tcl_FileObjCmd: writable} { removeFile $gorpfile removeDirectory $dirfile set dirfile [makeDirectory dir.file] -set gorpfile [makeFile abcde gorp.file] +set gorpfile [makeFile abcde górp.file] test cmdAH-18.1 {Tcl_FileObjCmd: executable} -returnCodes error -body { file executable a b } -result {wrong # args: should be "file executable name"} @@ -1356,12 +1356,12 @@ test cmdAH-19.1 {Tcl_FileObjCmd: exists} -returnCodes error -body { } -result {wrong # args: should be "file exists name"} test cmdAH-19.2 {Tcl_FileObjCmd: exists} {file exists $gorpfile} 0 test cmdAH-19.3 {Tcl_FileObjCmd: exists} { - file exists [file join [temporaryDirectory] dir.file gorp.file] + file exists [file join [temporaryDirectory] dir.file górp.file] } 0 catch { - set gorpfile [makeFile abcde gorp.file] + set gorpfile [makeFile abcde górp.file] set dirfile [makeDirectory dir.file] - set subgorp [makeFile 12345 [file join $dirfile gorp.file]] + set subgorp [makeFile 12345 [file join $dirfile górp.file]] } test cmdAH-19.4 {Tcl_FileObjCmd: exists} { file exists $gorpfile @@ -1422,7 +1422,7 @@ test cmdAH-19.12 {Bug 3608360: [file exists] mustn't do globbing} -setup { catch {testsetplatform $platform} removeFile $gorpfile -set gorpfile [makeFile "Test string" gorp.file] +set gorpfile [makeFile "Test string" górp.file] catch {file attributes $gorpfile -permissions 0o765} # avoid problems with non-local filesystems @@ -1842,7 +1842,7 @@ test cmdAH-27.4.1 { catch {testsetplatform $platform} removeFile $gorpfile -set gorpfile [makeFile "Test string" gorp.file] +set gorpfile [makeFile "Test string" górp.file] catch {file attributes $gorpfile -permissions 0o765} # stat -- cgit v0.12 From af1fba790a31650377bc909d82750931b6e31e60 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 15 Apr 2025 11:14:23 +0000 Subject: Fix TestplatformChmod() test function: It should always translate from UTF-8 to native, since the native encoding is not guaranteed to be UTF-8 --- win/tclWinTest.c | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/win/tclWinTest.c b/win/tclWinTest.c index 9e2fdca..22a7156 100644 --- a/win/tclWinTest.c +++ b/win/tclWinTest.c @@ -439,10 +439,14 @@ TestplatformChmod( DWORD dw; int isDir; TOKEN_USER *pTokenUser = NULL; + Tcl_DString ds; res = -1; /* Assume failure */ - attr = GetFileAttributesA(nativePath); + Tcl_DStringInit(&ds); + Tcl_UtfToExternalDString(NULL, nativePath, -1, &ds); + + attr = GetFileAttributesA(Tcl_DStringValue(&ds)); if (attr == 0xFFFFFFFF) { goto done; /* Not found */ } @@ -582,7 +586,7 @@ TestplatformChmod( * to remove inherited ACL (we need to overwrite the default ACL's in this case) */ - if (SetNamedSecurityInfoA((LPSTR)nativePath, SE_FILE_OBJECT, + if (SetNamedSecurityInfoA((LPSTR)Tcl_DStringValue(&ds), SE_FILE_OBJECT, DACL_SECURITY_INFORMATION | PROTECTED_DACL_SECURITY_INFORMATION, NULL, NULL, newAcl, NULL) == ERROR_SUCCESS) { res = 0; @@ -607,7 +611,9 @@ TestplatformChmod( } /* Run normal chmod command */ - return chmod(nativePath, pmode); + res = _chmod(Tcl_DStringValue(&ds), pmode); + Tcl_DStringFree(&ds); + return res; } /* -- cgit v0.12 From 75e82a98316746d68d3f65dafd946510d21e4d5e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 15 Apr 2025 11:22:33 +0000 Subject: Missing Tcl_DStringFree() --- win/tclWinTest.c | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/win/tclWinTest.c b/win/tclWinTest.c index 22a7156..c97eb66 100644 --- a/win/tclWinTest.c +++ b/win/tclWinTest.c @@ -606,12 +606,10 @@ TestplatformChmod( Tcl_Free(aceEntry[i].pSid); } - if (res != 0) { - return res; + if (res == 0) { + /* Run normal chmod command */ + res = _chmod(Tcl_DStringValue(&ds), pmode); } - - /* Run normal chmod command */ - res = _chmod(Tcl_DStringValue(&ds), pmode); Tcl_DStringFree(&ds); return res; } -- cgit v0.12 From 0802e6030b5ec940f0792c9d36e8421569fefbe0 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 16 Apr 2025 09:33:56 +0000 Subject: (cherry-pick): Clarify exec manpage << entry that the value is encoded and lineendings converted --- doc/exec.n | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/doc/exec.n b/doc/exec.n index df9b365..4992922 100644 --- a/doc/exec.n +++ b/doc/exec.n @@ -88,7 +88,9 @@ It is used as the standard input for the first command in the pipeline. .TP 15 \fB<<\0\fIvalue\fR . -\fIValue\fR is passed to the first command as its standard input. +\fIValue\fR is encoded using the system encoding, newlines +replaced by platform-specific line ending sequences, and then +passed to the first command as its standard input. .TP 15 \fB>\0\fIfileName\fR . -- cgit v0.12 From 82d26bceb483e3e642d54faadb8be4641d0e652b Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 16 Apr 2025 12:37:25 +0000 Subject: Clean up some code sections affected by change to always using 4-byte jumps --- generic/tclAssembly.c | 198 ++++++++++-------------------------------------- generic/tclCompCmds.c | 7 +- generic/tclCompCmdsGR.c | 5 +- generic/tclCompCmdsSZ.c | 2 + generic/tclCompile.c | 21 +++-- generic/tclCompile.h | 4 +- generic/tclExecute.c | 127 +++++++++++++++++++++++++++++-- generic/tclInt.h | 7 +- generic/tclOptimize.c | 14 +++- 9 files changed, 203 insertions(+), 182 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 33e31f0..d6cf07c 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -30,7 +30,6 @@ */ #include "tclInt.h" -#define ALLOW_DEPRECATED_OPCODES #include "tclCompile.h" #include "tclOOInt.h" #include @@ -116,8 +115,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' @@ -249,7 +246,7 @@ static void BBEmitInstInt4(AssemblyEnv* assemEnvPtr, int tblIdx, 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*); @@ -280,7 +277,6 @@ 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 AssemblyEnv* NewAssemblyEnv(CompileEnv*, int); static int ProcessCatches(AssemblyEnv*); @@ -501,8 +497,8 @@ static const TalInstDesc TalInstructionTable[] = { */ static const unsigned char NonThrowingByteCodes[] = { - INST_PUSH1, INST_PUSH, INST_POP, INST_DUP, /* 1-4 */ - INST_JUMP1, INST_JUMP, /* 34-35 */ + 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 */ @@ -2608,27 +2604,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. */ @@ -2670,114 +2654,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; } @@ -2868,55 +2800,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 = CurrentOffset(envPtr); - 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 @@ -2947,13 +2830,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); diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 6e0d20e..46e6a7c 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -1070,6 +1070,7 @@ TclCompileDictSetCmd( int i, numWords = (int) 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. @@ -1287,6 +1288,7 @@ TclCompileDictReplaceCmd( DefineLineInformation; /* TIP #280 */ int i, numWords = (int) parsePtr->numWords; Tcl_Token *tokenPtr; + /* TODO: Consider support for compiling expanded args. */ /* * Don't compile [dict replace $dict]; it's an edge case. @@ -1378,6 +1380,7 @@ TclCompileDictCreateCmd( Tcl_Token *keyToken, *valueToken; Tcl_Obj *keyObj, *valueObj, *dictObj; int i, numWords = parsePtr->numWords; + /* TODO: Consider support for compiling expanded args. */ if ((numWords & 1) == 0) { return TCL_ERROR; @@ -1719,9 +1722,8 @@ CompileDictEachCmd( BODY( bodyTokenPtr, 3); if (collect == TCL_EACH_COLLECT) { OP4( LOAD_SCALAR, keyVarIndex); - OP4( OVER, 1); + OP( SWAP); OP44( DICT_SET, 1, collectVar); - OP( POP); } OP( POP); } @@ -3246,6 +3248,7 @@ TclCompileFormatCmd( Tcl_Obj **objv, *formatObj, *tmpObj; const char *bytes, *start; int i, j, numWords = parsePtr->numWords; + /* TODO: Consider support for compiling expanded args. */ /* * Don't handle any guaranteed-error cases. diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index abcdc50..588481d 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -95,7 +95,6 @@ TclCompileGlobalCmd( Tcl_LVTIndex localIndex; int numWords, i; - /* TODO: Consider support for compiling expanded args. */ numWords = parsePtr->numWords; if (numWords < 2) { return TCL_ERROR; @@ -926,6 +925,7 @@ TclCompileLassignCmd( Tcl_Token *tokenPtr; int isScalar, numWords = (int) 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. @@ -1091,6 +1091,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 @@ -2727,6 +2728,7 @@ TclCompileObjectNextCmd( DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr = parsePtr->tokenPtr; int i; + /* TODO: Consider support for compiling expanded args. */ for (i=0 ; i<(int)parsePtr->numWords ; i++) { PUSH_TOKEN( tokenPtr, i); @@ -2747,6 +2749,7 @@ TclCompileObjectNextToCmd( DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr = parsePtr->tokenPtr; int i; + /* TODO: Consider support for compiling expanded args. */ if ((int)parsePtr->numWords < 2) { return TCL_ERROR; diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index b5cf6dd..9906c4d 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -216,6 +216,7 @@ TclCompileStringCatCmd( int i, numWords = parsePtr->numWords, numArgs; Tcl_Token *wordTokenPtr; Tcl_Obj *obj, *folded; + /* TODO: Consider support for compiling expanded args. */ /* Trivial case, no arg */ @@ -3902,6 +3903,7 @@ TclCompileYieldToCmd( Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); int i; + /* TODO: Consider support for compiling expanded args. */ if ((int)parsePtr->numWords < 2) { return TCL_ERROR; } diff --git a/generic/tclCompile.c b/generic/tclCompile.c index ea83da6..1292073 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -2196,7 +2196,7 @@ CompileExpanded( */ TclEmitInvoke(envPtr, INST_INVOKE_EXPANDED, wordIdx); - TclCheckStackDepth(depth+1, envPtr); + TclCheckStackDepth(depth + 1, envPtr); } static int @@ -2306,8 +2306,8 @@ CompileCommandTokens( ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; Tcl_Obj *cmdObj; Command *cmdPtr = NULL; - int code = TCL_ERROR; - int cmdKnown, expand = -1; + int code = TCL_ERROR, expand = -1; + int cmdKnown, numWords = (int) parsePtr->numWords; Tcl_Size *wlines, wlineat; Tcl_Size cmdLine = envPtr->line; Tcl_Size *clNext = envPtr->clNext; @@ -2315,7 +2315,7 @@ CompileCommandTokens( Tcl_Size startCodeOffset = CurrentOffset(envPtr); int depth = TclGetStackDepth(envPtr); - assert ((int)parsePtr->numWords > 0); + assert (numWords > 0); /* Precompile */ @@ -2360,7 +2360,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; @@ -2374,16 +2374,21 @@ 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); } } diff --git a/generic/tclCompile.h b/generic/tclCompile.h index e759d11..c929486 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -603,14 +603,14 @@ enum TclInstruction { /* Opcodes 10 to 23 */ DEPRECATED_OPCODE(INST_LOAD_SCALAR1), INST_LOAD_SCALAR, - INST_LOAD_SCALAR_STK, + DEPRECATED_OPCODE(INST_LOAD_SCALAR_STK), // Not used DEPRECATED_OPCODE(INST_LOAD_ARRAY1), INST_LOAD_ARRAY, INST_LOAD_ARRAY_STK, INST_LOAD_STK, DEPRECATED_OPCODE(INST_STORE_SCALAR1), INST_STORE_SCALAR, - INST_STORE_SCALAR_STK, + DEPRECATED_OPCODE(INST_STORE_SCALAR_STK), // Not used DEPRECATED_OPCODE(INST_STORE_ARRAY1), INST_STORE_ARRAY, INST_STORE_ARRAY_STK, diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 1dc3e60..5133a07 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 * Copyright © 2006-2008 Joe Mistachkin. All rights reserved. * @@ -16,7 +16,10 @@ */ #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" @@ -267,6 +270,7 @@ VarHashCreateVar( } while (0) #ifndef TCL_COMPILE_DEBUG +#ifndef REMOVE_DEPRECATED_OPCODES #define JUMP_PEEPHOLE_F(condition, pcAdjustment, cleanup) \ do { \ pc += (pcAdjustment); \ @@ -319,6 +323,48 @@ VarHashCreateVar( break; \ } \ } while (0) +#else +#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)); \ + break; \ + case INST_JUMP_TRUE: \ + NEXT_INST_F0(((condition)? TclGetInt4AtPtr(pc + 1) : 5), (cleanup)); \ + break; \ + default: \ + if ((condition) < 0) { \ + TclNewIntObj(objResultPtr, -1); \ + } else { \ + objResultPtr = TCONST((condition) > 0); \ + } \ + NEXT_INST_F(0, (cleanup), 1); \ + break; \ + } \ + } 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); \ + break; \ + case INST_JUMP_TRUE: \ + NEXT_INST_V(((condition)? TclGetInt4AtPtr(pc + 1) : 5), (cleanup), 0); \ + break; \ + default: \ + if ((condition) < 0) { \ + TclNewIntObj(objResultPtr, -1); \ + } else { \ + objResultPtr = TCONST((condition) > 0); \ + } \ + NEXT_INST_V(0, (cleanup), 1); \ + break; \ + } \ + } while (0) +#endif #else /* TCL_COMPILE_DEBUG */ #define JUMP_PEEPHOLE_F(condition, pcAdjustment, cleanup) \ do{ \ @@ -430,12 +476,14 @@ VarHashCreateVar( # define O2S(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 /* * DTrace instruction probe macros. @@ -2491,15 +2539,19 @@ TEBCresume( return TCL_OK; } +#ifndef REMOVE_DEPRECATED_OPCODES case INST_TAILCALL1: DEPRECATED_OPCODE_MARK(INST_TAILCALL1); opnd = TclGetUInt1AtPtr(pc + 1); goto doTailcall; +#endif case INST_TAILCALL: opnd = TclGetUInt4AtPtr(pc + 1); +#ifndef REMOVE_DEPRECATED_OPCODES doTailcall: +#endif if (!(iPtr->varFramePtr->isProcCallFrame & 1)) { TRACE(("%d => ERROR: tailcall in non-proc context\n", opnd)); Tcl_SetObjResult(interp, Tcl_NewStringObj( @@ -2576,12 +2628,14 @@ TEBCresume( (void) POP_OBJECT(); goto abnormalReturn; +#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); break; +#endif case INST_PUSH: objResultPtr = codePtr->objArrayPtr[TclGetUInt4AtPtr(pc + 1)]; @@ -2821,12 +2875,14 @@ TEBCresume( case INST_INVOKE_STK: objc = TclGetUInt4AtPtr(pc + 1); pcAdjustment = 5; +#ifndef REMOVE_DEPRECATED_OPCODES goto doInvocation; case INST_INVOKE_STK1: DEPRECATED_OPCODE_MARK(INST_INVOKE_STK1); objc = TclGetUInt1AtPtr(pc + 1); pcAdjustment = 2; +#endif doInvocation: objv = &OBJ_AT_DEPTH(objc - 1); @@ -2948,6 +3004,7 @@ TEBCresume( * common execution code. */ +#ifndef REMOVE_DEPRECATED_OPCODES case INST_LOAD_SCALAR1: DEPRECATED_OPCODE_MARK(INST_LOAD_SCALAR1); opnd = TclGetUInt1AtPtr(pc + 1); @@ -2970,6 +3027,7 @@ TEBCresume( arrayPtr = NULL; part1Ptr = part2Ptr = NULL; goto doCallPtrGetVar; +#endif case INST_LOAD_SCALAR: instLoadScalar: @@ -2997,6 +3055,7 @@ TEBCresume( case INST_LOAD_ARRAY: opnd = TclGetUInt4AtPtr(pc + 1); pcAdjustment = 5; +#ifndef REMOVE_DEPRECATED_OPCODES goto doLoadArray; case INST_LOAD_ARRAY1: @@ -3005,6 +3064,7 @@ TEBCresume( pcAdjustment = 2; doLoadArray: +#endif part1Ptr = NULL; part2Ptr = OBJ_AT_TOS; arrayPtr = LOCAL(opnd); @@ -3041,7 +3101,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 */ @@ -3100,17 +3163,21 @@ TEBCresume( int storeFlags; Tcl_Size len; +#ifndef REMOVE_DEPRECATED_OPCODES case INST_STORE_ARRAY1: DEPRECATED_OPCODE_MARK(INST_STORE_ARRAY1); opnd = TclGetUInt1AtPtr(pc + 1); pcAdjustment = 2; goto doStoreArrayDirect; +#endif case INST_STORE_ARRAY: opnd = TclGetUInt4AtPtr(pc + 1); pcAdjustment = 5; +#ifndef REMOVE_DEPRECATED_OPCODES doStoreArrayDirect: +#endif valuePtr = OBJ_AT_TOS; part2Ptr = OBJ_UNDER_TOS; arrayPtr = LOCAL(opnd); @@ -3133,17 +3200,21 @@ TEBCresume( part1Ptr = NULL; goto doStoreArrayDirectFailed; +#ifndef REMOVE_DEPRECATED_OPCODES case INST_STORE_SCALAR1: DEPRECATED_OPCODE_MARK(INST_STORE_SCALAR1); opnd = TclGetUInt1AtPtr(pc + 1); pcAdjustment = 2; goto doStoreScalarDirect; +#endif case INST_STORE_SCALAR: opnd = TclGetUInt4AtPtr(pc + 1); pcAdjustment = 5; +#ifndef REMOVE_DEPRECATED_OPCODES doStoreScalarDirect: +#endif valuePtr = OBJ_AT_TOS; varPtr = LOCAL(opnd); TRACE(("%u <- \"%.30s\" => ", opnd, O2S(valuePtr))); @@ -3213,7 +3284,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; @@ -3247,6 +3321,7 @@ TEBCresume( | TCL_LIST_ELEMENT); goto doStoreArray; +#ifndef REMOVE_DEPRECATED_OPCODES case INST_LAPPEND_ARRAY1: DEPRECATED_OPCODE_MARK(INST_LAPPEND_ARRAY1); opnd = TclGetUInt1AtPtr(pc + 1); @@ -3254,11 +3329,13 @@ TEBCresume( storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE | TCL_LIST_ELEMENT); goto doStoreArray; +#endif case INST_APPEND_ARRAY: opnd = TclGetUInt4AtPtr(pc + 1); pcAdjustment = 5; storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); +#ifndef REMOVE_DEPRECATED_OPCODES goto doStoreArray; case INST_APPEND_ARRAY1: @@ -3267,6 +3344,7 @@ TEBCresume( pcAdjustment = 2; storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); goto doStoreArray; +#endif doStoreArray: valuePtr = OBJ_AT_TOS; @@ -3296,6 +3374,7 @@ TEBCresume( | TCL_LIST_ELEMENT); goto doStoreScalar; +#ifndef REMOVE_DEPRECATED_OPCODES case INST_LAPPEND_SCALAR1: DEPRECATED_OPCODE_MARK(INST_LAPPEND_SCALAR1); opnd = TclGetUInt1AtPtr(pc + 1); @@ -3303,6 +3382,7 @@ TEBCresume( storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE | TCL_LIST_ELEMENT); goto doStoreScalar; +#endif case INST_APPEND_SCALAR: opnd = TclGetUInt4AtPtr(pc + 1); @@ -3310,12 +3390,14 @@ TEBCresume( storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); goto doStoreScalar; +#ifndef REMOVE_DEPRECATED_OPCODES case INST_APPEND_SCALAR1: DEPRECATED_OPCODE_MARK(INST_APPEND_ARRAY1); opnd = TclGetUInt1AtPtr(pc + 1); pcAdjustment = 2; storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); goto doStoreScalar; +#endif doStoreScalar: valuePtr = OBJ_AT_TOS; @@ -3531,14 +3613,17 @@ 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); incrPtr = POP_OBJECT(); switch (*pc) { +#ifndef REMOVE_DEPRECATED_OPCODES case INST_INCR_SCALAR1: DEPRECATED_OPCODE_MARK(INST_INCR_SCALAR1); pcAdjustment = 2; @@ -3547,6 +3632,7 @@ TEBCresume( DEPRECATED_OPCODE_MARK(INST_INCR_ARRAY1); pcAdjustment = 2; goto doIncrArray; +#endif default: pcAdjustment = 1; goto doIncrStk; @@ -3602,6 +3688,7 @@ TEBCresume( cleanup = ((part2Ptr == NULL)? 1 : 2); goto doIncrVar; +#ifndef REMOVE_DEPRECATED_OPCODES case INST_INCR_ARRAY1_IMM: DEPRECATED_OPCODE_MARK(INST_INCR_ARRAY1_IMM); opnd = TclGetUInt1AtPtr(pc + 1); @@ -3610,6 +3697,7 @@ TEBCresume( Tcl_IncrRefCount(incrPtr); pcAdjustment = 3; goto doIncrArray; +#endif case INST_INCR_ARRAY_IMM: opnd = TclGetUInt4AtPtr(pc + 1); @@ -3636,17 +3724,21 @@ TEBCresume( } goto doIncrVar; +#ifndef REMOVE_DEPRECATED_OPCODES case INST_INCR_SCALAR1_IMM: DEPRECATED_OPCODE_MARK(INST_INCR_SCALAR1_IMM); opnd = TclGetUInt1AtPtr(pc + 1); increment = TclGetInt1AtPtr(pc + 2); pcAdjustment = 3; goto doIncrScalarImm; +#endif case INST_INCR_SCALAR_IMM: opnd = TclGetUInt4AtPtr(pc + 1); increment = TclGetInt1AtPtr(pc + 5); pcAdjustment = 6; +#ifndef REMOVE_DEPRECATED_OPCODES doIncrScalarImm: +#endif cleanup = 0; varPtr = LOCAL(opnd); while (TclIsVarLink(varPtr)) { @@ -4300,12 +4392,14 @@ TEBCresume( * ----------------------------------------------------------------- */ +#ifndef REMOVE_DEPRECATED_OPCODES case INST_JUMP1: DEPRECATED_OPCODE_MARK(INST_JUMP1); opnd = TclGetInt1AtPtr(pc + 1); TRACE(("%d => new pc %" TCL_Z_MODIFIER "u\n", opnd, (size_t)(pc + opnd - codePtr->codeStart))); NEXT_INST_F0(opnd, 0); +#endif case INST_JUMP: opnd = TclGetInt4AtPtr(pc + 1); @@ -4318,6 +4412,7 @@ TEBCresume( /* TODO: consider rewrite so we don't compute the offset we're not * going to take. */ +#ifndef REMOVE_DEPRECATED_OPCODES case INST_JUMP_FALSE1: DEPRECATED_OPCODE_MARK(INST_JUMP_FALSE1); jmpOffset[0] = TclGetInt1AtPtr(pc + 1); @@ -4329,6 +4424,7 @@ TEBCresume( jmpOffset[0] = 2; jmpOffset[1] = TclGetInt1AtPtr(pc + 1); goto doCondJump; +#endif case INST_JUMP_FALSE: jmpOffset[0] = TclGetInt4AtPtr(pc + 1); /* FALSE offset */ @@ -4341,8 +4437,11 @@ TEBCresume( doCondJump: valuePtr = OBJ_AT_TOS; - TRACE(("%d => ", jmpOffset[ - (*pc==INST_JUMP_FALSE1 || *pc==INST_JUMP_FALSE) ? 0 : 1])); + TRACE(("%d => ", jmpOffset[( +#ifndef REMOVE_DEPRECATED_OPCODES + *pc==INST_JUMP_FALSE1 || +#endif + *pc==INST_JUMP_FALSE) ? 0 : 1])); /* TODO - check claim that taking address of b harms performance */ /* TODO - consider optimization search for constants */ @@ -4353,14 +4452,22 @@ TEBCresume( #ifdef TCL_COMPILE_DEBUG if (b) { - if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE)) { + if ((*pc == INST_JUMP_TRUE) +#ifndef REMOVE_DEPRECATED_OPCODES + || (*pc == INST_JUMP_TRUE1) +#endif + ) { TRACE_APPEND(("%.20s true, new pc %" TCL_Z_MODIFIER "u\n", O2S(valuePtr), (size_t)(pc + jmpOffset[1] - codePtr->codeStart))); } else { TRACE_APPEND(("%.20s true\n", O2S(valuePtr))); } } else { - if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE)) { + 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), @@ -4531,15 +4638,19 @@ TEBCresume( TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(1, 0, 1); +#ifndef REMOVE_DEPRECATED_OPCODES case INST_TCLOO_NEXT_CLASS1: DEPRECATED_OPCODE_MARK(INST_TCLOO_NEXT_CLASS1); opnd = TclGetUInt1AtPtr(pc + 1); pcAdjustment = 2; goto invokeNextClass; +#endif case INST_TCLOO_NEXT_CLASS: opnd = TclGetUInt4AtPtr(pc + 1); pcAdjustment = 5; +#ifndef REMOVE_DEPRECATED_OPCODES invokeNextClass: +#endif framePtr = iPtr->varFramePtr; valuePtr = OBJ_AT_DEPTH(opnd - 2); objv = &OBJ_AT_DEPTH(opnd - 1); @@ -4637,15 +4748,19 @@ TEBCresume( goto gotError; } +#ifndef REMOVE_DEPRECATED_OPCODES case INST_TCLOO_NEXT1: DEPRECATED_OPCODE_MARK(INST_TCLOO_NEXT1); opnd = TclGetUInt1AtPtr(pc + 1); pcAdjustment = 2; goto invokeNext; +#endif case INST_TCLOO_NEXT: opnd = TclGetUInt4AtPtr(pc + 1); pcAdjustment = 5; +#ifndef REMOVE_DEPRECATED_OPCODES invokeNext: +#endif objv = &OBJ_AT_DEPTH(opnd - 1); framePtr = iPtr->varFramePtr; skip = 1; @@ -6837,6 +6952,7 @@ TEBCresume( NEXT_INST_F(1, 0, 1); break; +#ifndef REMOVE_DEPRECATED_OPCODES case INST_RETURN_CODE_BRANCH1: { int code; @@ -6853,6 +6969,7 @@ TEBCresume( TRACE(("\"%s\" => jump offset %d\n", O2S(OBJ_AT_TOS), 2*code - 1)); NEXT_INST_F0(2*code - 1, 1); } +#endif case INST_RETURN_CODE_BRANCH: { int code; diff --git a/generic/tclInt.h b/generic/tclInt.h index 182d417..24eb5ef 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3965,9 +3965,10 @@ MODULE_SCOPE Tcl_Obj * TclStringReplace(Tcl_Interp *interp, Tcl_Obj *objPtr, MODULE_SCOPE Tcl_Obj * TclStringReverse(Tcl_Obj *objPtr, int flags); /* Flag values for the [string] ensemble functions. */ - -#define TCL_STRING_MATCH_NOCASE TCL_MATCH_NOCASE /* (1<<0) in tcl.h */ -#define TCL_STRING_IN_PLACE (1<<1) +enum StringOpFlags { + TCL_STRING_MATCH_NOCASE = TCL_MATCH_NOCASE, /* (1<<0) in tcl.h */ + TCL_STRING_IN_PLACE = (1<<1) /* Do in-place surgery on Tcl_Obj */ +}; /* * Functions defined in generic/tclVar.c and currently exported only for use diff --git a/generic/tclOptimize.c b/generic/tclOptimize.c index b6c7fe4..9e6aa4a 100644 --- a/generic/tclOptimize.c +++ b/generic/tclOptimize.c @@ -80,11 +80,13 @@ 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; +#endif case INST_JUMP: case INST_JUMP_TRUE: case INST_JUMP_FALSE: @@ -107,11 +109,13 @@ LocateTargetAddresses( DefineTargetAddress(tablePtr, targetInstPtr); } break; +#ifndef REMOVE_DEPRECATED_OPCODES case INST_RETURN_CODE_BRANCH1: for (i=TCL_ERROR ; i Date: Wed, 16 Apr 2025 17:32:50 +0000 Subject: Correct false claims in the header comment of RequiredPrecision() --- generic/tclStrToD.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index b0dc3d3..1d7fa40 100644 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -2299,7 +2299,8 @@ NormalizeRightward( * Determines the number of bits needed to hold an integer. * * Results: - * Returns the position of the most significant bit (0 - 63). Returns 0 + * Returns the position of the most significant bit (1 - 64), starting + * the counting at 1 for the LSB (RP(1) -> 1). Returns 0 * if the number is zero. * *---------------------------------------------------------------------- -- cgit v0.12 From 3bf35df9824903d8b8db6f427eaf8498e34b453b Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 16 Apr 2025 17:34:25 +0000 Subject: Correct false claims in the header comment of RequiredPrecision() --- generic/tclStrToD.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index b0dc3d3..1d7fa40 100644 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -2299,7 +2299,8 @@ NormalizeRightward( * Determines the number of bits needed to hold an integer. * * Results: - * Returns the position of the most significant bit (0 - 63). Returns 0 + * Returns the position of the most significant bit (1 - 64), starting + * the counting at 1 for the LSB (RP(1) -> 1). Returns 0 * if the number is zero. * *---------------------------------------------------------------------- -- cgit v0.12 From 54b083e10a904c0dfe1de0627b991b0c65fb89f1 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 16 Apr 2025 18:04:19 +0000 Subject: Work in progress deploying further optimization and usage of TclLog2(). --- generic/tclCompile.h | 1 - generic/tclInt.h | 1 + 2 files changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclCompile.h b/generic/tclCompile.h index c4b6f65..b3692aa 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -1154,7 +1154,6 @@ MODULE_SCOPE void TclFinalizeLoopExceptionRange(CompileEnv *envPtr, int 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, CompileEnv *envPtr); diff --git a/generic/tclInt.h b/generic/tclInt.h index d430164..134c496 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3436,6 +3436,7 @@ MODULE_SCOPE Tcl_Obj * TclLsetList(Tcl_Interp *interp, Tcl_Obj *listPtr, MODULE_SCOPE Tcl_Obj * TclLsetFlat(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Size indexCount, Tcl_Obj *const indexArray[], Tcl_Obj *valuePtr); +MODULE_SCOPE int TclLog2(long long value); 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, -- cgit v0.12 From 2cf3949e322cb1f5644049c1de17577f6e564a2d Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 16 Apr 2025 18:54:05 +0000 Subject: Expose TclLog2() to all builds, not limited to --enable-symbols=compile --- generic/tclExecute.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 4cd4078..2c18e1e 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -9539,7 +9539,6 @@ TclExprFloatError( } } -#ifdef TCL_COMPILE_STATS /* *---------------------------------------------------------------------- * @@ -9591,6 +9590,7 @@ TclLog2( return result; } +#ifdef TCL_COMPILE_STATS /* *---------------------------------------------------------------------- * -- cgit v0.12 From 74dd7b71b703ffec899af092b97af8235ea47831 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 16 Apr 2025 19:26:34 +0000 Subject: The routine RequiredPrecision() is just a variation on the same function provided by TclLog2(). Re-implement as a simple wrapper. --- generic/tclStrToD.c | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index 1d7fa40..3a6470e 100644 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -2313,6 +2313,13 @@ RequiredPrecision( int rv; unsigned int wi; + if (sizeof(Tcl_WideUInt) <= sizeof(long long)) { + return 1 + ( w ? TclLog2((long long) w) : 0); + } + + /* TODO: Are there any circumstances where we will continue + * to the alternative below? */ + if (w & ((Tcl_WideUInt)0xFFFFFFFF << 32)) { wi = (unsigned int)(w >> 32); rv = 32; } else { -- cgit v0.12 From 03a71502613280bcf3ada08bce15a4980ba5fd69 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 17 Apr 2025 09:07:25 +0000 Subject: Add INST_TCLOO_ID/tclooId to TAL --- generic/tclAssembly.c | 1 + 1 file changed, 1 insertion(+) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index d6cf07c..22b339e 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -470,6 +470,7 @@ static const TalInstDesc TalInstructionTable[] = { {"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}, -- cgit v0.12 From 93c9217da1ea81c9677a2e9f91ebbb3f409114fb Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 17 Apr 2025 09:09:14 +0000 Subject: remove unread field --- generic/tclAssembly.c | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 22b339e..590ecea 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -62,8 +62,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 @@ -2556,8 +2554,7 @@ AllocBB( CompileEnv* envPtr = assemEnvPtr->envPtr; BasicBlock *bb = (BasicBlock*)Tcl_Alloc(sizeof(BasicBlock)); - bb->originalStartOffset = - bb->startOffset = CurrentOffset(envPtr); + bb->startOffset = CurrentOffset(envPtr); bb->startLine = assemEnvPtr->cmdLine + 1; bb->jumpOffset = -1; bb->jumpLine = -1; -- cgit v0.12 From 7add1b667d2f8b5d5c914b4b4a0676548cc528e8 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 17 Apr 2025 14:47:13 +0000 Subject: Another round of -Wconversion warning fixes, see [03cff7a777] --- generic/regcomp.c | 22 ++--- generic/regexec.c | 5 +- generic/regguts.h | 2 +- generic/tclBasic.c | 6 +- generic/tclCompCmds.c | 215 ++++++++++++++++++++++++---------------------- generic/tclCompCmdsGR.c | 114 ++++++++++++------------ generic/tclCompCmdsSZ.c | 159 ++++++++++++++++++---------------- generic/tclCompExpr.c | 12 +-- generic/tclCompile.c | 103 +++++++++++----------- generic/tclCompile.h | 27 +++--- generic/tclExecute.c | 30 +++---- generic/tclIO.c | 4 +- generic/tclInt.h | 4 +- generic/tclInterp.c | 4 +- generic/tclOODefineCmds.c | 6 +- generic/tclParse.c | 2 +- generic/tclStringObj.c | 2 +- generic/tclTest.c | 10 +-- generic/tclTestABSList.c | 4 +- generic/tclTestObj.c | 8 +- generic/tclVar.c | 8 +- win/tclWinChan.c | 8 +- win/tclWinConsole.c | 12 +-- win/tclWinFCmd.c | 6 +- win/tclWinFile.c | 14 +-- win/tclWinPipe.c | 2 +- win/tclWinSock.c | 6 +- win/tclWinTest.c | 2 +- 28 files changed, 416 insertions(+), 381 deletions(-) diff --git a/generic/regcomp.c b/generic/regcomp.c index 949f397..e20e271 100644 --- a/generic/regcomp.c +++ b/generic/regcomp.c @@ -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); @@ -789,11 +789,11 @@ 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; + size_t m, n; struct subre *atom; /* atom's subtree */ struct subre *t; int cap; /* capturing parens? */ - int pos; /* positive lookahead? */ + size_t pos; /* positive lookahead? */ size_t subno; /* capturing-parens or backref number */ int atomtype; int qprefer; /* quantifier short/long preference */ @@ -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/regexec.c b/generic/regexec.c index 7b84f0f..a6170e9 100644 --- a/generic/regexec.c +++ b/generic/regexec.c @@ -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..c393cd8 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/tclBasic.c b/generic/tclBasic.c index 317f6de..243009b 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -5852,7 +5852,7 @@ TclArgumentBCEnter( Tcl_Size pc) { ExtCmdLoc *eclPtr; - Tcl_Size word; + int word; ECL *ePtr; CFWordBC *lastPtr = NULL; Interp *iPtr = (Interp *) interp; @@ -6105,7 +6105,7 @@ TclEvalObjEx( * 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. */ { int result = TCL_OK; NRE_callback *rootPtr = TOP_CB(interp); @@ -6124,7 +6124,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; diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 4305fd6..9b1b1ce 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -128,11 +128,12 @@ TclCompileAppendCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr, *valueTokenPtr; - int isScalar, localIndex, numWords, i; + int isScalar; + Tcl_Size i, numWords, localIndex; /* TODO: Consider support for compiling expanded args. */ numWords = parsePtr->numWords; - if (numWords == 1) { + if (numWords == 1 || numWords > INT_MAX) { return TCL_ERROR; } else if (numWords == 2) { /* @@ -253,7 +254,8 @@ TclCompileArrayExistsCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - int isScalar, localIndex; + int isScalar; + Tcl_Size localIndex; if (parsePtr->numWords != 2) { return TCL_ERROR; @@ -262,7 +264,7 @@ TclCompileArrayExistsCmd( tokenPtr = TokenAfter(parsePtr->tokenPtr); PushVarNameWord(interp, tokenPtr, envPtr, TCL_NO_ELEMENT, &localIndex, &isScalar, 1); - if (!isScalar) { + if (!isScalar || localIndex > INT_MAX) { return TCL_ERROR; } @@ -285,11 +287,11 @@ TclCompileArraySetCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr, *dataTokenPtr; - int isScalar, localIndex, code = TCL_OK; + int isScalar, code = TCL_OK; int isDataLiteral, isDataValid, isDataEven; - Tcl_Size len; - int keyVar, valVar, infoIndex; - int fwd, offsetBack, offsetFwd; + Tcl_Size localIndex, len; + Tcl_Size keyVar, valVar, infoIndex; + Tcl_Size fwd, offsetBack, offsetFwd; Tcl_Obj *literalObj; ForeachInfo *infoPtr; @@ -341,7 +343,7 @@ TclCompileArraySetCmd( PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_ELEMENT, &localIndex, &isScalar, 1); - if (!isScalar) { + if (!isScalar || localIndex > INT_MAX) { code = TCL_ERROR; goto done; } @@ -459,7 +461,8 @@ TclCompileArrayUnsetCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); - int isScalar, localIndex; + int isScalar; + Tcl_Size localIndex; if (parsePtr->numWords != 2) { return TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr); @@ -576,15 +579,15 @@ TclCompileCatchCmd( DefineLineInformation; /* TIP #280 */ JumpFixup jumpFixup; Tcl_Token *cmdTokenPtr, *resultNameTokenPtr, *optsNameTokenPtr; - int resultIndex, optsIndex, range, dropScript = 0; - int depth = TclGetStackDepth(envPtr); + Tcl_Size resultIndex, optsIndex, range, dropScript = 0; + Tcl_Size depth = TclGetStackDepth(envPtr); /* * 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 ((parsePtr->numWords < 2) || (parsePtr->numWords > 4)) { return TCL_ERROR; } @@ -593,7 +596,7 @@ TclCompileCatchCmd( * (not in a procedure), don't compile it inline: the payoff is too small. */ - if (((int)parsePtr->numWords >= 3) && !EnvHasLVT(envPtr)) { + if ((parsePtr->numWords >= 3) && !EnvHasLVT(envPtr)) { return TCL_ERROR; } @@ -604,7 +607,7 @@ TclCompileCatchCmd( resultIndex = optsIndex = -1; cmdTokenPtr = TokenAfter(parsePtr->tokenPtr); - if ((int)parsePtr->numWords >= 3) { + if (parsePtr->numWords >= 3) { resultNameTokenPtr = TokenAfter(cmdTokenPtr); /* DGP */ resultIndex = LocalScalarFromToken(resultNameTokenPtr, envPtr); @@ -856,7 +859,7 @@ TclCompileConcatCmd( DefineLineInformation; /* TIP #280 */ Tcl_Obj *objPtr, *listObj; Tcl_Token *tokenPtr; - int i; + Tcl_Size i; /* TODO: Consider compiling expansion case. */ if (parsePtr->numWords == 1) { @@ -866,6 +869,8 @@ TclCompileConcatCmd( PushStringLiteral(envPtr, ""); return TCL_OK; + } else if (parsePtr->numWords > INT_MAX) { + return TCL_ERROR; } /* @@ -874,7 +879,7 @@ TclCompileConcatCmd( */ TclNewObj(listObj); - for (i = 1, tokenPtr = parsePtr->tokenPtr; i < (int)parsePtr->numWords; i++) { + for (i = 1, tokenPtr = parsePtr->tokenPtr; i < parsePtr->numWords; i++) { tokenPtr = TokenAfter(tokenPtr); TclNewObj(objPtr); if (!TclWordKnownAtCompileTime(tokenPtr, objPtr)) { @@ -903,7 +908,10 @@ TclCompileConcatCmd( * General case: runtime concat. */ - for (i = 1, tokenPtr = parsePtr->tokenPtr; i < (int)parsePtr->numWords; i++) { + if (parsePtr->numWords > 256) { + return TCL_ERROR; + } + for (i = 1, tokenPtr = parsePtr->tokenPtr; i < parsePtr->numWords; i++) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, i); } @@ -941,7 +949,8 @@ TclCompileConstCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr, *valueTokenPtr; - int isScalar, localIndex; + int isScalar; + Tcl_Size localIndex; /* * Need exactly two arguments. @@ -966,7 +975,7 @@ TclCompileConstCmd( * If the user specified an array element, we don't bother handling * that. */ - if (!isScalar) { + if (!isScalar || localIndex > INT_MAX) { return TCL_ERROR; } @@ -1081,14 +1090,14 @@ TclCompileDictSetCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - int i, dictVarIndex; + Tcl_Size i, dictVarIndex; Tcl_Token *varTokenPtr; /* * There must be at least one argument after the command. */ - if ((int)parsePtr->numWords < 4) { + if (parsePtr->numWords < 4 || parsePtr->numWords > INT_MAX) { return TCL_ERROR; } @@ -1109,7 +1118,7 @@ TclCompileDictSetCmd( */ tokenPtr = TokenAfter(varTokenPtr); - for (i=2 ; i< (int)parsePtr->numWords ; i++) { + for (i=2 ; i< parsePtr->numWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } @@ -1118,7 +1127,7 @@ TclCompileDictSetCmd( * Now emit the instruction to do the dict manipulation. */ - TclEmitInstInt4( INST_DICT_SET, (int)parsePtr->numWords-3, envPtr); + TclEmitInstInt4( INST_DICT_SET, parsePtr->numWords-3, envPtr); TclEmitInt4( dictVarIndex, envPtr); TclAdjustStackDepth(-1, envPtr); return TCL_OK; @@ -1135,13 +1144,14 @@ TclCompileDictIncrCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr, *keyTokenPtr; - int dictVarIndex, incrAmount; + Tcl_Size 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); @@ -1207,7 +1217,7 @@ TclCompileDictGetCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - int i; + Tcl_Size i; /* * There must be at least two arguments after the command (the single-arg @@ -1215,7 +1225,7 @@ TclCompileDictGetCmd( */ /* TODO: Consider support for compiling expanded args. */ - if ((int)parsePtr->numWords < 3) { + if (parsePtr->numWords < 3 || parsePtr->numWords > INT_MAX) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -1224,11 +1234,11 @@ TclCompileDictGetCmd( * Only compile this because we need INST_DICT_GET anyway. */ - for (i=1 ; i<(int)parsePtr->numWords ; i++) { + for (i=1 ; inumWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } - TclEmitInstInt4(INST_DICT_GET, (int)parsePtr->numWords-2, envPtr); + TclEmitInstInt4(INST_DICT_GET, parsePtr->numWords-2, envPtr); TclAdjustStackDepth(-1, envPtr); return TCL_OK; } @@ -1243,23 +1253,23 @@ TclCompileDictGetWithDefaultCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - int i; + Tcl_Size i; /* * There must be at least three arguments after the command. */ /* TODO: Consider support for compiling expanded args. */ - if ((int)parsePtr->numWords < 4) { + if (parsePtr->numWords < 4 || parsePtr->numWords > INT_MAX) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); - for (i=1 ; i<(int)parsePtr->numWords ; i++) { + for (i=1 ; inumWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } - TclEmitInstInt4(INST_DICT_GET_DEF, (int)parsePtr->numWords-3, envPtr); + TclEmitInstInt4(INST_DICT_GET_DEF, parsePtr->numWords-3, envPtr); TclAdjustStackDepth(-2, envPtr); return TCL_OK; } @@ -1274,7 +1284,7 @@ TclCompileDictExistsCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - int i; + Tcl_Size i; /* * There must be at least two arguments after the command (the single-arg @@ -1282,7 +1292,7 @@ TclCompileDictExistsCmd( */ /* TODO: Consider support for compiling expanded args. */ - if ((int)parsePtr->numWords < 3) { + if (parsePtr->numWords < 3 || parsePtr->numWords > INT_MAX) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -1291,11 +1301,11 @@ TclCompileDictExistsCmd( * Now we do the code generation. */ - for (i=1 ; i<(int)parsePtr->numWords ; i++) { + for (i=1 ; inumWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } - TclEmitInstInt4(INST_DICT_EXISTS, (int)parsePtr->numWords-2, envPtr); + TclEmitInstInt4(INST_DICT_EXISTS, parsePtr->numWords-2, envPtr); TclAdjustStackDepth(-1, envPtr); return TCL_OK; } @@ -1311,7 +1321,7 @@ TclCompileDictUnsetCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - int i, dictVarIndex; + Tcl_Size i, dictVarIndex; /* * There must be at least one argument after the variable name for us to @@ -1319,7 +1329,7 @@ TclCompileDictUnsetCmd( */ /* TODO: Consider support for compiling expanded args. */ - if ((int)parsePtr->numWords < 3) { + if (parsePtr->numWords < 3 || parsePtr->numWords > INT_MAX) { return TCL_ERROR; } @@ -1339,7 +1349,7 @@ TclCompileDictUnsetCmd( * Remaining words (the key path) can be handled normally. */ - for (i=2 ; i<(int)parsePtr->numWords ; i++) { + for (i=2 ; inumWords ; i++) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, i); } @@ -1348,7 +1358,7 @@ TclCompileDictUnsetCmd( * Now emit the instruction to do the dict manipulation. */ - TclEmitInstInt4( INST_DICT_UNSET, (int)parsePtr->numWords-2, envPtr); + TclEmitInstInt4( INST_DICT_UNSET, parsePtr->numWords-2, envPtr); TclEmitInt4( dictVarIndex, envPtr); return TCL_OK; } @@ -1363,14 +1373,13 @@ TclCompileDictCreateCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ - int worker; /* Temp var for building the value in. */ + Tcl_Size worker; /* Temp var for building the value in. */ Tcl_Token *tokenPtr; Tcl_Obj *keyObj, *valueObj, *dictObj; const char *bytes; - int i; - Tcl_Size len; + Tcl_Size i, len; - if ((parsePtr->numWords & 1) == 0) { + if ((parsePtr->numWords & 1) == 0 || parsePtr->numWords > INT_MAX) { return TCL_ERROR; } @@ -1381,7 +1390,7 @@ TclCompileDictCreateCmd( tokenPtr = TokenAfter(parsePtr->tokenPtr); TclNewObj(dictObj); Tcl_IncrRefCount(dictObj); - for (i=1 ; i<(int)parsePtr->numWords ; i+=2) { + for (i=1 ; inumWords ; i+=2) { TclNewObj(keyObj); Tcl_IncrRefCount(keyObj); if (!TclWordKnownAtCompileTime(tokenPtr, keyObj)) { @@ -1431,7 +1440,7 @@ TclCompileDictCreateCmd( Emit14Inst( INST_STORE_SCALAR, worker, envPtr); TclEmitOpcode( INST_POP, envPtr); tokenPtr = TokenAfter(parsePtr->tokenPtr); - for (i=1 ; i<(int)parsePtr->numWords ; i+=2) { + for (i=1 ; inumWords ; i+=2) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, i+1); @@ -1458,7 +1467,8 @@ TclCompileDictMergeCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - int i, workerIndex, infoIndex, outLoop; + Tcl_Size i; + Tcl_Size workerIndex, infoIndex, outLoop; /* * Deal with some special edge cases. Note that in the case with one @@ -1466,7 +1476,7 @@ TclCompileDictMergeCmd( */ /* TODO: Consider support for compiling expanded args. (less likely) */ - if ((int)parsePtr->numWords < 2) { + if (parsePtr->numWords < 2) { PushStringLiteral(envPtr, ""); return TCL_OK; } else if (parsePtr->numWords == 2) { @@ -1508,7 +1518,7 @@ TclCompileDictMergeCmd( outLoop = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); TclEmitInstInt4( INST_BEGIN_CATCH4, outLoop, envPtr); ExceptionRangeStarts(envPtr, outLoop); - for (i=2 ; i<(int)parsePtr->numWords ; i++) { + for (i=2 ; inumWords ; i++) { /* * Get the dictionary, and merge its pairs into the first dict (using * a small loop). @@ -1601,11 +1611,11 @@ CompileDictEachCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *varsTokenPtr, *dictTokenPtr, *bodyTokenPtr; - int keyVarIndex, valueVarIndex, nameChars, loopRange, catchRange; - int infoIndex, jumpDisplacement, bodyTargetOffset, emptyTargetOffset; + Tcl_Size keyVarIndex, valueVarIndex, nameChars, loopRange, catchRange; + Tcl_Size infoIndex, jumpDisplacement, bodyTargetOffset, emptyTargetOffset; Tcl_Size numVars; - int endTargetOffset; - int collectVar = -1; /* Index of temp var holding the result + Tcl_Size endTargetOffset; + Tcl_Size collectVar = -1; /* Index of temp var holding the result * dict. */ const char **argv; Tcl_DString buffer; @@ -1827,7 +1837,7 @@ TclCompileDictUpdateCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ - int i, dictIndex, numVars, range, infoIndex; + Tcl_Size i, dictIndex, numVars, range, infoIndex; Tcl_Token **keyTokenPtrs, *dictVarTokenPtr, *bodyTokenPtr, *tokenPtr; DictUpdateInfo *duiPtr; JumpFixup jumpFixup; @@ -1836,7 +1846,7 @@ TclCompileDictUpdateCmd( * There must be at least one argument after the command. */ - if ((int)parsePtr->numWords < 5) { + if (parsePtr->numWords < 5) { return TCL_ERROR; } @@ -1845,7 +1855,7 @@ TclCompileDictUpdateCmd( * dict update ? ...? */ - if (((int)parsePtr->numWords - 1) & 1) { + if (!(parsePtr->numWords & 1) || parsePtr->numWords > INT_MAX) { return TCL_ERROR; } numVars = (parsePtr->numWords - 3) / 2; @@ -1979,7 +1989,8 @@ TclCompileDictAppendCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - int i, dictVarIndex; + Tcl_Size i; + Tcl_Size dictVarIndex; /* * There must be at least two argument after the command. And we impose an @@ -1988,7 +1999,7 @@ TclCompileDictAppendCmd( */ /* TODO: Consider support for compiling expanded args. */ - if ((int)parsePtr->numWords<4 || (int)parsePtr->numWords>100) { + if (parsePtr->numWords<4 || parsePtr->numWords>100) { return TCL_ERROR; } @@ -2007,12 +2018,12 @@ TclCompileDictAppendCmd( */ tokenPtr = TokenAfter(tokenPtr); - for (i=2 ; i<(int)parsePtr->numWords ; i++) { + for (i=2 ; inumWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } - if ((int)parsePtr->numWords > 4) { - TclEmitInstInt1(INST_STR_CONCAT1, (int)parsePtr->numWords-3, envPtr); + if (parsePtr->numWords > 4) { + TclEmitInstInt1(INST_STR_CONCAT1, parsePtr->numWords-3, envPtr); } /* @@ -2034,7 +2045,7 @@ TclCompileDictLappendCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr, *keyTokenPtr, *valueTokenPtr; - int dictVarIndex; + Tcl_Size dictVarIndex; /* * There must be three arguments after the command. @@ -2078,8 +2089,9 @@ TclCompileDictWithCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { DefineLineInformation; /* TIP #280 */ - int i, range, varNameTmp = -1, pathTmp = -1, keysTmp, gotPath; - int dictVar, bodyIsEmpty = 1; + Tcl_Size dictVar, i; + Tcl_Size range, varNameTmp = -1, pathTmp = -1, keysTmp; + int bodyIsEmpty = 1, gotPath; Tcl_Token *varTokenPtr, *tokenPtr; JumpFixup jumpFixup; const char *ptr, *end; @@ -2089,7 +2101,7 @@ TclCompileDictWithCmd( */ /* TODO: Consider support for compiling expanded args. */ - if ((int)parsePtr->numWords < 3) { + if (parsePtr->numWords < 3 || parsePtr->numWords > INT_MAX) { return TCL_ERROR; } @@ -2100,7 +2112,7 @@ TclCompileDictWithCmd( varTokenPtr = TokenAfter(parsePtr->tokenPtr); tokenPtr = TokenAfter(varTokenPtr); - for (i=3 ; i<(int)parsePtr->numWords ; i++) { + for (i=3 ; inumWords ; i++) { tokenPtr = TokenAfter(tokenPtr); } if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { @@ -2128,7 +2140,7 @@ TclCompileDictWithCmd( * Determine if we're manipulating a dict in a simple local variable. */ - gotPath = ((int)parsePtr->numWords > 3); + gotPath = (parsePtr->numWords > 3); dictVar = LocalScalarFromToken(varTokenPtr, envPtr); /* @@ -2147,11 +2159,11 @@ TclCompileDictWithCmd( */ tokenPtr = TokenAfter(varTokenPtr); - for (i=2 ; i<(int)parsePtr->numWords-1 ; i++) { + for (i=2 ; inumWords-1 ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } - TclEmitInstInt4(INST_LIST, (int)parsePtr->numWords-3,envPtr); + TclEmitInstInt4(INST_LIST, parsePtr->numWords-3,envPtr); Emit14Inst( INST_LOAD_SCALAR, dictVar, envPtr); TclEmitInstInt4(INST_OVER, 1, envPtr); TclEmitOpcode( INST_DICT_EXPAND, envPtr); @@ -2174,11 +2186,11 @@ TclCompileDictWithCmd( */ tokenPtr = varTokenPtr; - for (i=1 ; i<(int)parsePtr->numWords-1 ; i++) { + for (i=1 ; inumWords-1 ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } - TclEmitInstInt4(INST_LIST, (int)parsePtr->numWords-3,envPtr); + TclEmitInstInt4(INST_LIST, parsePtr->numWords-3,envPtr); TclEmitInstInt4(INST_OVER, 1, envPtr); TclEmitOpcode( INST_LOAD_STK, envPtr); TclEmitInstInt4(INST_OVER, 1, envPtr); @@ -2229,11 +2241,11 @@ TclCompileDictWithCmd( } tokenPtr = TokenAfter(varTokenPtr); if (gotPath) { - for (i=2 ; i<(int)parsePtr->numWords-1 ; i++) { + for (i=2 ; inumWords-1 ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } - TclEmitInstInt4( INST_LIST, (int)parsePtr->numWords-3,envPtr); + TclEmitInstInt4( INST_LIST, parsePtr->numWords-3,envPtr); Emit14Inst( INST_STORE_SCALAR, pathTmp, envPtr); TclEmitOpcode( INST_POP, envPtr); } @@ -2295,7 +2307,7 @@ TclCompileDictWithCmd( if (dictVar == -1) { Emit14Inst( INST_LOAD_SCALAR, varNameTmp, envPtr); } - if ((int)parsePtr->numWords > 3) { + if (parsePtr->numWords > 3) { Emit14Inst( INST_LOAD_SCALAR, pathTmp, envPtr); } else { PushStringLiteral(envPtr, ""); @@ -2433,7 +2445,7 @@ TclCompileErrorCmd( * General syntax: [error message ?errorInfo? ?errorCode?] */ - if ((int)parsePtr->numWords < 2 || (int)parsePtr->numWords > 4) { + if (parsePtr->numWords < 2 || parsePtr->numWords > 4) { return TCL_ERROR; } @@ -2501,7 +2513,7 @@ TclCompileExprCmd( { Tcl_Token *firstWordPtr; - if (parsePtr->numWords == 1) { + if (parsePtr->numWords == 1 || parsePtr->numWords > INT_MAX) { return TCL_ERROR; } @@ -2513,7 +2525,7 @@ TclCompileExprCmd( 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; } @@ -2546,8 +2558,8 @@ TclCompileForCmd( DefineLineInformation; /* TIP #280 */ Tcl_Token *startTokenPtr, *testTokenPtr, *nextTokenPtr, *bodyTokenPtr; JumpFixup jumpEvalCondFixup; - int bodyCodeOffset, nextCodeOffset, jumpDist; - int bodyRange, nextRange; + Tcl_Size bodyCodeOffset, nextCodeOffset, jumpDist; + Tcl_Size bodyRange, nextRange; if (parsePtr->numWords != 5) { return TCL_ERROR; @@ -2762,8 +2774,9 @@ CompileEachloopCmd( * record in the ByteCode. */ Tcl_Token *tokenPtr, *bodyTokenPtr; - int jumpBackOffset, infoIndex, range; - int numWords, numLists, i, code = TCL_OK; + Tcl_Size jumpBackOffset, infoIndex, range; + Tcl_Size numWords, numLists, i; + int code = TCL_OK; Tcl_Size j; Tcl_Obj *varListObj = NULL; @@ -2776,8 +2789,8 @@ CompileEachloopCmd( return TCL_ERROR; } - numWords = (int)parsePtr->numWords; - if ((numWords < 4) || (numWords%2 != 0)) { + numWords = parsePtr->numWords; + if ((numWords < 4) || (numWords > INT_MAX) || (numWords%2 != 0)) { return TCL_ERROR; } @@ -2844,7 +2857,7 @@ CompileEachloopCmd( for (j = 0; j < numVars; j++) { Tcl_Obj *varNameObj; const char *bytes; - int varIndex; + Tcl_Size varIndex; Tcl_Size length; Tcl_ListObjIndex(NULL, varListObj, j, &varNameObj); @@ -2970,7 +2983,7 @@ DupForeachInfo( 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 *)); @@ -3018,7 +3031,7 @@ FreeForeachInfo( { 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]; @@ -3227,14 +3240,13 @@ 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, len; /* * Don't handle any guaranteed-error cases. */ - if ((int)parsePtr->numWords < 2) { + if (parsePtr->numWords < 2 || parsePtr->numWords > INT_MAX) { return TCL_ERROR; } @@ -3251,8 +3263,8 @@ 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 **)Tcl_Alloc((parsePtr->numWords-2) * sizeof(Tcl_Obj *)); + for (i=0 ; i+2 < parsePtr->numWords ; i++) { tokenPtr = TokenAfter(tokenPtr); TclNewObj(objv[i]); Tcl_IncrRefCount(objv[i]); @@ -3267,7 +3279,7 @@ TclCompileFormatCmd( */ tmpObj = Tcl_Format(interp, TclGetString(formatObj), - (int)parsePtr->numWords-2, objv); + parsePtr->numWords-2, objv); for (; --i>=0 ;) { Tcl_DecrRefCount(objv[i]); } @@ -3328,7 +3340,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 != parsePtr->numWords || i > 125) { Tcl_DecrRefCount(formatObj); return TCL_ERROR; } @@ -3426,12 +3438,13 @@ TclCompileFormatCmd( *---------------------------------------------------------------------- */ -size_t +Tcl_Size TclLocalScalarFromToken( Tcl_Token *tokenPtr, CompileEnv *envPtr) { - int isScalar, index; + Tcl_Size index; + int isScalar; TclPushVarName(NULL, tokenPtr, envPtr, TCL_NO_ELEMENT, &index, &isScalar); if (!isScalar) { @@ -3440,7 +3453,7 @@ TclLocalScalarFromToken( return index; } -size_t +Tcl_Size TclLocalScalar( const char *bytes, size_t numBytes, @@ -3491,15 +3504,15 @@ TclPushVarName( 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. */ + Tcl_Size *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 nameLen, elNameLen, localIndex; + int simpleVarName; Tcl_Size elemTokenCount = 0, removedParen = 0; int allocedTokens = 0; diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index cab74a5..ef0c855 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_Size IndexTailVarIfKnown(Tcl_Interp *interp, Tcl_Token *varTokenPtr, CompileEnv *envPtr); /* @@ -92,7 +92,7 @@ TclCompileGlobalCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr; - int localIndex, numWords, i; + Tcl_Size localIndex, numWords, i; /* TODO: Consider support for compiling expanded args. */ numWords = parsePtr->numWords; @@ -122,7 +122,7 @@ TclCompileGlobalCmd( for (i=1; i INT_MAX) { return TCL_ERROR; } @@ -180,9 +180,10 @@ TclCompileIfCmd( * to the end of the "if" when that PC is * determined. */ Tcl_Token *tokenPtr, *testTokenPtr; - int jumpIndex = 0; /* Avoid compiler warning. */ + Tcl_Size jumpIndex = 0; /* Avoid compiler warning. */ size_t numBytes, j; - int jumpFalseDist, numWords, wordIdx, code; + int jumpFalseDist, code; + Tcl_Size numWords, wordIdx; const char *word; int realCond = 1; /* Set to 0 for static conditions: * "if 0 {..}" */ @@ -476,7 +477,8 @@ TclCompileIncrCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr, *incrTokenPtr; - int isScalar, localIndex, haveImmValue; + int isScalar, haveImmValue; + Tcl_Size localIndex; Tcl_WideInt immValue; if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) { @@ -672,7 +674,8 @@ TclCompileInfoExistsCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - int isScalar, localIndex; + int isScalar; + Tcl_Size localIndex; if (parsePtr->numWords != 2) { return TCL_ERROR; @@ -845,7 +848,8 @@ TclCompileLappendCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr, *valueTokenPtr; - int isScalar, localIndex, numWords, i; + int isScalar; + Tcl_Size localIndex, numWords, i; /* TODO: Consider support for compiling expanded args. */ numWords = parsePtr->numWords; @@ -960,7 +964,8 @@ TclCompileLassignCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - int isScalar, localIndex, numWords, idx; + int isScalar; + Tcl_Size localIndex, numWords, idx; numWords = parsePtr->numWords; @@ -1030,7 +1035,7 @@ TclCompileLassignCmd( */ TclEmitInstInt4( INST_LIST_RANGE_IMM, idx, envPtr); - TclEmitInt4( (int)TCL_INDEX_END, envPtr); + TclEmitInt4( TCL_INDEX_END, envPtr); return TCL_OK; } @@ -1063,7 +1068,8 @@ 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. @@ -1153,10 +1159,12 @@ TclCompileListCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *valueTokenPtr; - int i, numWords, concat, build; + Tcl_Size i, numWords; + int concat, build; Tcl_Obj *listObj, *objPtr; - if (parsePtr->numWords == 1) { + numWords = parsePtr->numWords; + if (numWords == 1) { /* * [list] without arguments just pushes an empty object. */ @@ -1170,7 +1178,6 @@ TclCompileListCmd( * implement with a simple push. */ - numWords = parsePtr->numWords; valueTokenPtr = TokenAfter(parsePtr->tokenPtr); TclNewObj(listObj); for (i = 1; i < numWords && listObj != NULL; i++) { @@ -1193,7 +1200,6 @@ TclCompileListCmd( * Push the all values onto the stack. */ - numWords = parsePtr->numWords; valueTokenPtr = TokenAfter(parsePtr->tokenPtr); concat = build = 0; for (i = 1; i < numWords; i++) { @@ -1233,7 +1239,7 @@ TclCompileListCmd( if (concat && numWords == 2) { TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); - TclEmitInt4( (int)TCL_INDEX_END, envPtr); + TclEmitInt4( TCL_INDEX_END, envPtr); } return TCL_OK; } @@ -1358,9 +1364,9 @@ TclCompileLinsertCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - int i; + Tcl_Size i; - if ((int)parsePtr->numWords < 3) { + if (parsePtr->numWords < 3) { return TCL_ERROR; } @@ -1371,7 +1377,7 @@ TclCompileLinsertCmd( CompileWord(envPtr, tokenPtr, interp, 2); /* Push new elements to be inserted */ - for (i=3 ; i<(int)parsePtr->numWords ; i++) { + for (i=3 ; inumWords ; i++) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, i); } @@ -1410,7 +1416,7 @@ TclCompileLreplaceCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - int i; + Tcl_Size i; if (parsePtr->numWords < 4) { return TCL_ERROR; @@ -1425,7 +1431,7 @@ TclCompileLreplaceCmd( CompileWord(envPtr, tokenPtr, interp, 3); /* Push new elements to be inserted */ - for (i=4 ; i< (int)parsePtr->numWords ; i++) { + for (i=4 ; i< parsePtr->numWords ; i++) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, i); } @@ -1490,20 +1496,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_Size localIndex; /* Index of var in local var table. */ int isScalar; /* Flag == 1 if scalar, 0 if array. */ - int i; + Tcl_Size i; /* * Check argument count. */ /* TODO: Consider support for compiling expanded args. */ - if ((int)parsePtr->numWords < 3) { + if (parsePtr->numWords < 3) { /* * Fail at run time, not in compilation. */ @@ -1527,7 +1533,7 @@ TclCompileLsetCmd( * Push the "index" args and the new element value. */ - for (i=2 ; i<(int)parsePtr->numWords ; ++i) { + for (i=2 ; inumWords ; ++i) { varTokenPtr = TokenAfter(varTokenPtr); CompileWord(envPtr, varTokenPtr, interp, i); } @@ -1731,7 +1737,7 @@ TclCompileNamespaceQualifiersCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); - int off; + Tcl_Size off; if (parsePtr->numWords != 2) { return TCL_ERROR; @@ -1802,7 +1808,8 @@ TclCompileNamespaceUpvarCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr, *otherTokenPtr, *localTokenPtr; - int localIndex, numWords, i; + Tcl_Size localIndex; + Tcl_Size numWords, i; if (envPtr->procPtr == NULL) { return TCL_ERROR; @@ -1812,7 +1819,7 @@ TclCompileNamespaceUpvarCmd( * Only compile [namespace upvar ...]: needs an even number of args, >=4 */ - numWords = (int)parsePtr->numWords; + numWords = parsePtr->numWords; if ((numWords % 2) || (numWords < 4)) { return TCL_ERROR; } @@ -1864,7 +1871,7 @@ TclCompileNamespaceWhichCmd( Tcl_Token *tokenPtr, *opt; int idx; - if ((int)parsePtr->numWords < 2 || (int)parsePtr->numWords > 3) { + if (parsePtr->numWords < 2 || parsePtr->numWords > 3) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -1927,7 +1934,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; + int nocase, exact, sawLast, simple; const char *str; /* @@ -1937,7 +1945,7 @@ TclCompileRegexpCmd( * regexp ?-nocase? ?--? {^staticString$} $var */ - if ((int)parsePtr->numWords < 3) { + if (parsePtr->numWords < 3) { return TCL_ERROR; } @@ -1952,7 +1960,7 @@ TclCompileRegexpCmd( * handling, but satisfies our stricter needs. */ - for (i = 1; i < (int)parsePtr->numWords - 2; i++) { + for (i = 1; i < parsePtr->numWords - 2; i++) { varTokenPtr = TokenAfter(varTokenPtr); if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { /* @@ -1978,7 +1986,7 @@ TclCompileRegexpCmd( } } - if (((int)parsePtr->numWords - i) != 2) { + if ((parsePtr->numWords - i) != 2) { /* * We don't support capturing to variables. */ @@ -2031,7 +2039,7 @@ TclCompileRegexpCmd( } if (!simple) { - CompileWord(envPtr, varTokenPtr, interp, (int)parsePtr->numWords - 2); + CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords - 2); } /* @@ -2039,7 +2047,7 @@ TclCompileRegexpCmd( */ varTokenPtr = TokenAfter(varTokenPtr); - CompileWord(envPtr, varTokenPtr, interp, (int)parsePtr->numWords - 1); + CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords - 1); if (simple) { if (exact && !nocase) { @@ -2116,7 +2124,7 @@ TclCompileRegsubCmd( int exact, quantified, result = TCL_ERROR; Tcl_Size len; - if ((int)parsePtr->numWords < 5 || (int)parsePtr->numWords > 6) { + if (parsePtr->numWords < 5 || parsePtr->numWords > 6) { return TCL_ERROR; } @@ -2223,7 +2231,7 @@ TclCompileRegsubCmd( PushLiteral(envPtr, bytes, len); bytes = TclGetStringFromObj(replacementObj, &len); PushLiteral(envPtr, bytes, len); - CompileWord(envPtr, stringTokenPtr, interp, (int)parsePtr->numWords - 2); + CompileWord(envPtr, stringTokenPtr, interp, parsePtr->numWords - 2); TclEmitOpcode( INST_STR_MAP, envPtr); done: @@ -2270,9 +2278,9 @@ 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); @@ -2372,7 +2380,7 @@ TclCompileReturnCmd( * We have default return options and we're in a proc ... */ - int index = envPtr->exceptArrayNext - 1; + Tcl_Size index = envPtr->exceptArrayNext - 1; int enclosingCatch = 0; while (index >= 0) { @@ -2517,7 +2525,7 @@ TclCompileUpvarCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr, *otherTokenPtr, *localTokenPtr; - int localIndex, numWords, i; + Tcl_Size localIndex, numWords, i; Tcl_Obj *objPtr; if (envPtr->procPtr == NULL) { @@ -2623,7 +2631,7 @@ TclCompileVariableCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr, *valueTokenPtr; - int localIndex, numWords, i; + Tcl_Size localIndex, numWords, i; numWords = parsePtr->numWords; if (numWords < 2) { @@ -2697,7 +2705,7 @@ TclCompileVariableCmd( *---------------------------------------------------------------------- */ -static int +static Tcl_Size IndexTailVarIfKnown( TCL_UNUSED(Tcl_Interp *), Tcl_Token *varTokenPtr, /* Token representing the variable name */ @@ -2705,10 +2713,10 @@ IndexTailVarIfKnown( { Tcl_Obj *tailPtr; const char *tailName, *p; - int n = varTokenPtr->numComponents; - Tcl_Size len; + Tcl_Size n = varTokenPtr->numComponents; + Tcl_Size len, localIndex; Tcl_Token *lastTokenPtr; - int full, localIndex; + int full; /* * Determine if the tail is (a) known at compile time, and (b) not an @@ -2797,13 +2805,13 @@ TclCompileObjectNextCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr = parsePtr->tokenPtr; - int i; + Tcl_Size i; - if ((int)parsePtr->numWords > 255) { + if (parsePtr->numWords > 255) { return TCL_ERROR; } - for (i=0 ; i<(int)parsePtr->numWords ; i++) { + for (i=0 ; inumWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } @@ -2821,13 +2829,13 @@ TclCompileObjectNextToCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr = parsePtr->tokenPtr; - int i; + Tcl_Size i; - if ((int)parsePtr->numWords < 2 || (int)parsePtr->numWords > 255) { + if (parsePtr->numWords < 2 || parsePtr->numWords > 255) { return TCL_ERROR; } - for (i=0 ; i<(int)parsePtr->numWords ; i++) { + for (i=0 ; inumWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 313cb58..e24ca52 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -44,19 +44,19 @@ static void IssueSwitchChainedTests(Tcl_Interp *interp, Tcl_Size numWords, Tcl_Token **bodyToken, Tcl_Size *bodyLines, Tcl_Size **bodyNext); static void IssueSwitchJumpTable(Tcl_Interp *interp, - CompileEnv *envPtr, int numWords, + CompileEnv *envPtr, Tcl_Size numWords, Tcl_Token **bodyToken, Tcl_Size *bodyLines, Tcl_Size **bodyContLines); 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, int *matchCodes, + Tcl_Obj **matchClauses, Tcl_Size *resultVarIndices, + Tcl_Size *optionVarIndices, Tcl_Token **handlerTokens); 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, int *matchCodes, + Tcl_Obj **matchClauses, Tcl_Size *resultVarIndices, + Tcl_Size *optionVarIndices, Tcl_Token **handlerTokens, Tcl_Token *finallyToken); static int IssueTryFinallyInstructions(Tcl_Interp *interp, CompileEnv *envPtr, Tcl_Token *bodyToken, @@ -130,7 +130,8 @@ TclCompileSetCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr, *valueTokenPtr; - int isAssignment, isScalar, localIndex, numWords; + int isAssignment, isScalar; + Tcl_Size localIndex, numWords; numWords = parsePtr->numWords; if ((numWords != 2) && (numWords != 3)) { @@ -222,7 +223,7 @@ 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; @@ -518,7 +519,8 @@ 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; + Tcl_Size range, end; + int allowEmpty = 0; InstStringClassType strClassType; Tcl_Obj *isClass; @@ -572,7 +574,7 @@ TclCompileStringIsCmd( * 5. Lists */ - CompileWord(envPtr, tokenPtr, interp, (int)parsePtr->numWords-1); + CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1); switch (t) { case STR_IS_ALNUM: @@ -617,7 +619,7 @@ TclCompileStringIsCmd( if (allowEmpty) { OP1( STR_CLASS, strClassType); } else { - int over, over2; + Tcl_Size over, over2; OP( DUP); OP1( STR_CLASS, strClassType); @@ -637,7 +639,7 @@ TclCompileStringIsCmd( case STR_IS_TRUE: OP( TRY_CVT_TO_BOOLEAN); switch (t) { - int over, over2; + Tcl_Size over, over2; case STR_IS_BOOL: if (allowEmpty) { @@ -685,7 +687,7 @@ TclCompileStringIsCmd( break; case STR_IS_DOUBLE: { - int satisfied, isEmpty; + Tcl_Size satisfied, isEmpty; if (allowEmpty) { OP( DUP); @@ -716,7 +718,7 @@ TclCompileStringIsCmd( case STR_IS_WIDE: case STR_IS_ENTIER: if (allowEmpty) { - int testNumType; + Tcl_Size testNumType; OP( DUP); OP( NUM_TYPE); @@ -1054,7 +1056,7 @@ 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; } @@ -1176,7 +1178,7 @@ TclCompileStringReplaceCmd( if (last == INT_MAX) { OP( POP); /* Pop original */ } else { - OP44( STR_RANGE_IMM, last + 1, (int)TCL_INDEX_END); + OP44( STR_RANGE_IMM, last + 1, TCL_INDEX_END); OP1( STR_CONCAT1, 2); } return TCL_OK; @@ -1208,7 +1210,7 @@ TclCompileStringReplaceCmd( 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) { @@ -1219,7 +1221,7 @@ TclCompileStringReplaceCmd( OP( DUP); OP44( STR_RANGE_IMM, 0, first-1); OP4( REVERSE, 2); - OP44( STR_RANGE_IMM, last + 1, (int)TCL_INDEX_END); + OP44( STR_RANGE_IMM, last + 1, TCL_INDEX_END); OP1( STR_CONCAT1, 2); return TCL_OK; } @@ -1451,9 +1453,9 @@ 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; @@ -1518,7 +1520,7 @@ TclSubstCompile( CompileEnv *envPtr) { Tcl_Token *endTokenPtr, *tokenPtr; - int breakOffset = 0, count = 0; + Tcl_Size breakOffset = 0, count = 0; Tcl_Size bline = line; Tcl_Parse parse; Tcl_InterpState state = NULL; @@ -1544,8 +1546,9 @@ TclSubstCompile( for (endTokenPtr = tokenPtr + parse.numTokens; tokenPtr < endTokenPtr; tokenPtr = TokenAfter(tokenPtr)) { - Tcl_Size length; - int literal, catchRange, breakJump; + Tcl_Size length, catchRange; + int literal; + Tcl_Size breakJump; char buf[4] = ""; JumpFixup startFixup, okFixup, returnFixup, breakFixup; JumpFixup continueFixup, otherFixup, endFixup; @@ -1787,7 +1790,7 @@ 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; @@ -2123,7 +2126,7 @@ IssueSwitchChainedTests( 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. */ + Tcl_Size *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 * of continuation bodies starts, or -1 if @@ -2132,7 +2135,7 @@ IssueSwitchChainedTests( * the current (or next) real body. */ int nextArmFixupIndex; int simple, exact; /* For extracting the type of regexp. */ - int i; + Tcl_Size i; /* * Generate a test for each arm. @@ -2141,8 +2144,8 @@ IssueSwitchChainedTests( 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)); + fixupTargetArray = (Tcl_Size *)TclStackAlloc(interp, sizeof(Tcl_Size) * numBodyTokens); + memset(fixupTargetArray, 0, numBodyTokens * sizeof(Tcl_Size)); fixupCount = 0; foundDefault = 0; for (i=0 ; i=0 ; i--) { if (TclFixupForwardJump(envPtr, &fixupArray[i], fixupTargetArray[i] - fixupArray[i].codeOffset, 127)) { - int j; + Tcl_Size j; for (j=i-1 ; j>=0 ; j--) { if (fixupTargetArray[j] > fixupArray[i].codeOffset) { @@ -2359,7 +2362,7 @@ static void IssueSwitchJumpTable( Tcl_Interp *interp, /* Context for compiling script bodies. */ CompileEnv *envPtr, /* Holds resulting instructions. */ - int numBodyTokens, /* Number of tokens describing things the + 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. */ @@ -2368,8 +2371,9 @@ IssueSwitchJumpTable( Tcl_Size **bodyContLines) /* Array of continuation line info. */ { JumptableInfo *jtPtr; - int infoIndex, isNew, *finalFixups, numRealBodies = 0, jumpLocation; - int mustGenerate, foundDefault, jumpToDefault, i; + Tcl_Size infoIndex, *finalFixups; + int isNew, mustGenerate, foundDefault; + Tcl_Size i, numRealBodies = 0, jumpLocation, jumpToDefault; Tcl_DString buffer; Tcl_HashEntry *hPtr; @@ -2386,7 +2390,7 @@ IssueSwitchJumpTable( 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)); + finalFixups = (Tcl_Size *)TclStackAlloc(interp, sizeof(Tcl_Size) * (numBodyTokens/2)); foundDefault = 0; mustGenerate = 1; @@ -2661,7 +2665,7 @@ TclCompileTailcallCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr = parsePtr->tokenPtr; - int i; + Tcl_Size i; if (parsePtr->numWords < 2 || parsePtr->numWords >= 256 || envPtr->procPtr == NULL) { @@ -2671,11 +2675,11 @@ TclCompileTailcallCmd( /* 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++) { + for (i=1 ; inumWords ; i++) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, i); } - TclEmitInstInt1( INST_TAILCALL, (int)parsePtr->numWords, envPtr); + TclEmitInstInt1( INST_TAILCALL, parsePtr->numWords, envPtr); return TCL_OK; } @@ -2706,7 +2710,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; @@ -2808,12 +2812,14 @@ 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; Tcl_Token *bodyToken, *finallyToken, *tokenPtr; Tcl_Token **handlerTokens = NULL; Tcl_Obj **matchClauses = NULL; - int *matchCodes=NULL, *resultVarIndices=NULL, *optionVarIndices=NULL; - int i; + int *matchCodes=NULL; + Tcl_Size *resultVarIndices=NULL, *optionVarIndices=NULL; + Tcl_Size i; if (numWords < 2) { return TCL_ERROR; @@ -2845,8 +2851,8 @@ TclCompileTryCmd( 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); + resultVarIndices = (Tcl_Size *)TclStackAlloc(interp, sizeof(Tcl_Size) * numHandlers); + optionVarIndices = (Tcl_Size *)TclStackAlloc(interp, sizeof(Tcl_Size) * numHandlers); for (i=0 ; itokenPtr ; i<(int)parsePtr->numWords ; i++) { + for (i=1,varTokenPtr=parsePtr->tokenPtr ; inumWords ; i++) { Tcl_Obj *leadingWord; TclNewObj(leadingWord); @@ -3698,7 +3708,7 @@ TclCompileUnsetCmd( for (i=0; inumWords ; i++) { + for (i=1+haveFlags ; inumWords ; 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 @@ -3763,7 +3773,8 @@ TclCompileWhileCmd( DefineLineInformation; /* TIP #280 */ Tcl_Token *testTokenPtr, *bodyTokenPtr; JumpFixup jumpEvalCondFixup; - int testCodeOffset, bodyCodeOffset, jumpDist, range, code, boolVal; + int code, boolVal; + Tcl_Size bodyCodeOffset, testCodeOffset, range, jumpDist; int loopMayEnd = 1; /* This is set to 0 if it is recognized as an * infinite loop. */ Tcl_Obj *boolObj; @@ -3981,14 +3992,14 @@ TclCompileYieldToCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); - int i; + Tcl_Size i; if ((int)parsePtr->numWords < 2) { return TCL_ERROR; } OP( NS_CURRENT); - for (i = 1 ; i < (int)parsePtr->numWords ; i++) { + for (i = 1 ; i < parsePtr->numWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } @@ -4153,7 +4164,7 @@ CompileComparisonOpCmd( Tcl_Token *tokenPtr; /* TODO: Consider support for compiling expanded args. */ - if ((int)parsePtr->numWords < 3) { + if (parsePtr->numWords < 3) { PUSH("1"); } else if (parsePtr->numWords == 3) { tokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -4168,7 +4179,7 @@ CompileComparisonOpCmd( return TCL_ERROR; } else { - int tmpIndex = AnonymousLocal(envPtr); + Tcl_Size tmpIndex = AnonymousLocal(envPtr); Tcl_Size words; tokenPtr = TokenAfter(parsePtr->tokenPtr); diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index e36df94..f1765c1 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -740,7 +740,7 @@ ParseExpr( * Tricky case: see test expr-62.10 */ - int scanned2 = scanned; + Tcl_Size scanned2 = scanned; do { scanned2 += TclParseAllWhiteSpace( start + scanned2, numBytes - scanned2); @@ -842,7 +842,7 @@ ParseExpr( Tcl_Token *tokenPtr; const char *end = start; - int wordIndex; + Tcl_Size wordIndex; int code = TCL_OK; /* @@ -1504,13 +1504,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 +1577,7 @@ ConvertTreeToTokens( * do better. */ - int toCopy = tokenPtr->numComponents + 1; + Tcl_Size toCopy = tokenPtr->numComponents + 1; if (tokenPtr->numComponents == tokenPtr[1].numComponents + 1) { /* @@ -2386,7 +2386,7 @@ CompileExprTree( break; } } else { - int pc1, pc2, target; + Tcl_Size pc1, pc2, target; switch (nodePtr->lexeme) { case START: diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 1532947..8292144 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1722,7 +1722,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) { @@ -1793,7 +1793,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--) { @@ -1840,7 +1840,7 @@ TclCompileInvocation( { DefineLineInformation; size_t wordIdx = 0; - int depth = TclGetStackDepth(envPtr); + Tcl_Size depth = TclGetStackDepth(envPtr); if (cmdObj) { CompileCmdLiteral(interp, cmdObj, envPtr); @@ -1880,12 +1880,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) { @@ -1945,7 +1945,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 @@ -2018,7 +2018,7 @@ CompileCmdCompileProc( return TCL_ERROR; } -static int +static Tcl_Size CompileCommandTokens( Tcl_Interp *interp, Tcl_Parse *parsePtr, @@ -2036,9 +2036,9 @@ CompileCommandTokens( Tcl_Size *clNext = envPtr->clNext; Tcl_Size cmdIdx = envPtr->numCommands; Tcl_Size startCodeOffset = envPtr->codeNext - envPtr->codeStart; - int depth = TclGetStackDepth(envPtr); + Tcl_Size depth = TclGetStackDepth(envPtr); - assert ((int)parsePtr->numWords > 0); + assert (parsePtr->numWords > 0); /* Precompile */ @@ -2083,7 +2083,7 @@ CompileCommandTokens( } } if (cmdPtr && !(cmdPtr->flags & CMD_COMPILES_EXPANDED)) { - expand = ExpandRequested(parsePtr->tokenPtr, (int)parsePtr->numWords); + expand = ExpandRequested(parsePtr->tokenPtr, parsePtr->numWords); if (expand) { /* We need to expand, but compileProc cannot. */ cmdPtr = NULL; @@ -2098,15 +2098,15 @@ CompileCommandTokens( if (code == TCL_ERROR) { if (expand < 0) { - expand = ExpandRequested(parsePtr->tokenPtr, (int)parsePtr->numWords); + expand = ExpandRequested(parsePtr->tokenPtr, parsePtr->numWords); } if (expand) { CompileExpanded(interp, parsePtr->tokenPtr, - cmdKnown ? cmdObj : NULL, (int)parsePtr->numWords, envPtr); + cmdKnown ? cmdObj : NULL, parsePtr->numWords, envPtr); } else { TclCompileInvocation(interp, parsePtr->tokenPtr, - cmdKnown ? cmdObj : NULL, (int)parsePtr->numWords, envPtr); + cmdKnown ? cmdObj : NULL, parsePtr->numWords, envPtr); } } @@ -2144,12 +2144,12 @@ TclCompileScript( * first null character. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { - int lastCmdIdx = -1; /* Index into envPtr->cmdMapPtr of the last + Tcl_Size lastCmdIdx = -1; /* 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. */ 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) { @@ -2258,7 +2258,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; @@ -2420,13 +2420,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 @@ -2490,7 +2490,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; @@ -2679,14 +2679,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, @@ -2706,7 +2705,7 @@ TclCompileExprWords( wordPtr = tokenPtr; for (i = 0; i < numWords; i++) { CompileTokens(envPtr, wordPtr, interp); - if (i < (numWords - 1)) { + if (i + 1 < numWords) { PushStringLiteral(envPtr, " "); } wordPtr += wordPtr->numComponents + 1; @@ -3487,9 +3486,9 @@ TclGetInnermostExceptionRange( while (i > 0) { 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)) { @@ -3520,7 +3519,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"); @@ -3546,7 +3545,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"); @@ -3586,13 +3585,13 @@ 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); } - TclAdjustStackDepth((int)(auxPtr->expandTargetDepth - envPtr->currStackDepth), + TclAdjustStackDepth((auxPtr->expandTargetDepth - envPtr->currStackDepth), envPtr); envPtr->currStackDepth = auxPtr->expandTargetDepth; } @@ -3619,7 +3618,7 @@ static void StartExpanding( CompileEnv *envPtr) { - int i; + Tcl_Size i; TclEmitOpcode(INST_EXPAND_START, envPtr); @@ -3628,7 +3627,7 @@ StartExpanding( * where this expansion started. */ - for (i=0 ; i<(int)envPtr->exceptArrayNext ; i++) { + for (i=0 ; iexceptArrayNext ; i++) { ExceptionRange *rangePtr = &envPtr->exceptArrayPtr[i]; ExceptionAux *auxPtr = &envPtr->exceptAuxArrayPtr[i]; @@ -3636,7 +3635,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) { @@ -3676,11 +3675,11 @@ StartExpanding( void TclFinalizeLoopExceptionRange( CompileEnv *envPtr, - int range) + Tcl_Size 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) { @@ -3692,7 +3691,7 @@ TclFinalizeLoopExceptionRange( * there is no need to fuss around with updating code offsets. */ - for (i=0 ; i<(int)auxPtr->numBreakTargets ; i++) { + for (i=0 ; inumBreakTargets ; i++) { site = envPtr->codeStart + auxPtr->breakTargets[i]; offset = rangePtr->breakOffset - auxPtr->breakTargets[i]; TclUpdateInstInt4AtPc(INST_JUMP4, offset, site); @@ -3952,9 +3951,9 @@ TclEmitForwardJump( */ jumpFixupPtr->jumpType = jumpType; - jumpFixupPtr->codeOffset = envPtr->codeNext - envPtr->codeStart; - jumpFixupPtr->cmdIndex = envPtr->numCommands; - jumpFixupPtr->exceptIndex = envPtr->exceptArrayNext; + jumpFixupPtr->codeOffset = (unsigned int)(envPtr->codeNext - envPtr->codeStart); + jumpFixupPtr->cmdIndex = (int)envPtr->numCommands; + jumpFixupPtr->exceptIndex = (int)envPtr->exceptArrayNext; switch (jumpType) { case TCL_UNCONDITIONAL_JUMP: @@ -4002,12 +4001,12 @@ TclFixupForwardJump( * 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 + Tcl_Size jumpDist, /* Jump distance to set in jump instr. */ + Tcl_Size distThreshold) /* Maximum distance before the two byte jump * is grown to five bytes. */ { unsigned char *jumpPc, *p; - int firstCmd, lastCmd, firstRange, lastRange, k; + Tcl_Size firstCmd, lastCmd, firstRange, lastRange, k; size_t numBytes; if (jumpDist <= distThreshold) { @@ -4092,14 +4091,14 @@ TclFixupForwardJump( for (k = 0 ; k < (int)envPtr->exceptArrayNext ; k++) { ExceptionAux *auxPtr = &envPtr->exceptAuxArrayPtr[k]; - int i; + Tcl_Size i; - for (i=0 ; i<(int)auxPtr->numBreakTargets ; i++) { + for (i=0 ; inumBreakTargets ; i++) { if (jumpFixupPtr->codeOffset < auxPtr->breakTargets[i]) { auxPtr->breakTargets[i] += 3; } } - for (i=0 ; i<(int)auxPtr->numContinueTargets ; i++) { + for (i=0 ; inumContinueTargets ; i++) { if (jumpFixupPtr->codeOffset < auxPtr->continueTargets[i]) { auxPtr->continueTargets[i] += 3; } @@ -4139,9 +4138,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_Size loopRange = 0, breakRange = 0, continueRange = 0; + Tcl_Size cleanup, depth = TclGetStackDepth(envPtr); /* * Parse the arguments. @@ -4350,13 +4349,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; @@ -4437,7 +4436,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. diff --git a/generic/tclCompile.h b/generic/tclCompile.h index c4b6f65..c3e5105 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -1130,8 +1130,8 @@ MODULE_SCOPE Tcl_Obj * TclFetchLiteral(CompileEnv *envPtr, Tcl_Size index); MODULE_SCOPE Tcl_Size TclFindCompiledLocal(const char *name, Tcl_Size nameChars, int create, CompileEnv *envPtr); MODULE_SCOPE int TclFixupForwardJump(CompileEnv *envPtr, - JumpFixup *jumpFixupPtr, int jumpDist, - int distThreshold); + JumpFixup *jumpFixupPtr, Tcl_Size jumpDist, + Tcl_Size distThreshold); MODULE_SCOPE void TclFreeCompileEnv(CompileEnv *envPtr); MODULE_SCOPE void TclFreeJumpFixupArray(JumpFixupArray *fixupArrayPtr); MODULE_SCOPE int TclGetIndexFromToken(Tcl_Token *tokenPtr, @@ -1151,14 +1151,14 @@ MODULE_SCOPE void TclAddLoopBreakFixup(CompileEnv *envPtr, 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_Size TclLocalScalar(const char *bytes, size_t numBytes, CompileEnv *envPtr); -MODULE_SCOPE size_t TclLocalScalarFromToken(Tcl_Token *tokenPtr, +MODULE_SCOPE Tcl_Size TclLocalScalarFromToken(Tcl_Token *tokenPtr, CompileEnv *envPtr); MODULE_SCOPE void TclOptimizeBytecode(void *envPtr); #ifdef TCL_COMPILE_DEBUG @@ -1174,7 +1174,7 @@ 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_Size *localIndexPtr, int *isScalarPtr); MODULE_SCOPE void TclPreserveByteCode(ByteCode *codePtr); MODULE_SCOPE void TclReleaseByteCode(ByteCode *codePtr); @@ -1212,7 +1212,7 @@ MODULE_SCOPE int TclPushProcCallFrame(void *clientData, /* * Simplified form to access AuxData. * - * void *TclFetchAuxData(CompileEng *envPtr, int index); + * void *TclFetchAuxData(CompileEng *envPtr, Tcl_Size index); */ #define TclFetchAuxData(envPtr, index) \ @@ -1229,11 +1229,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; } } @@ -1272,13 +1272,16 @@ TclCheckStackDepth( static inline void TclUpdateStackReqs( unsigned char op, - int i, + Tcl_Size i, CompileEnv *envPtr) { int delta = tclInstructionTable[op].stackEffect; if (delta) { if (delta == INT_MIN) { - delta = 1 - i; + if (i > INT_MAX || i < INT_MIN+2) { + Tcl_Panic("%s: stack effect too big", "TclUpdateStackReqs"); + } + delta = 1 - (int)i; } TclAdjustStackDepth(delta, envPtr); } @@ -1309,7 +1312,7 @@ TclUpdateStackReqs( TclExpandCodeArray(envPtr); \ } \ *(envPtr)->codeNext++ = (unsigned char) (op); \ - TclUpdateAtCmdStart(op, envPtr); \ + TclUpdateAtCmdStart((unsigned char)op, envPtr); \ TclUpdateStackReqs((unsigned char)op, 0, envPtr); \ } while (0) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 4cd4078..a844186 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -2031,7 +2031,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() */ @@ -4224,7 +4224,7 @@ TEBCresume( case INST_JUMP4: opnd = TclGetInt4AtPtr(pc+1); TRACE(("%d => new pc %" TCL_Z_MODIFIER "u\n", opnd, - (size_t)(pc + opnd - codePtr->codeStart))); + (pc + opnd - codePtr->codeStart))); NEXT_INST_F(opnd, 0, 0); { @@ -4266,8 +4266,8 @@ 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))); + TRACE_APPEND(("%.20s true, new pc %" TCL_T_MODIFIER "u\n", O2S(valuePtr), + (pc + jmpOffset[1] - codePtr->codeStart))); } else { TRACE_APPEND(("%.20s true\n", O2S(valuePtr))); } @@ -4275,8 +4275,8 @@ TEBCresume( if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE4)) { 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 %" TCL_T_MODIFIER "u\n", O2S(valuePtr), + (pc + jmpOffset[0] - codePtr->codeStart))); } } #endif @@ -4301,7 +4301,7 @@ TEBCresume( 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))); + (pc - codePtr->codeStart + jumpOffset))); NEXT_INST_F(jumpOffset, 1, 0); } else { TRACE_APPEND(("not found in table\n")); @@ -4338,12 +4338,12 @@ TEBCresume( 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; } @@ -4495,7 +4495,7 @@ TEBCresume( } else { fprintf(stdout, "%" TCL_SIZE_MODIFIER "d: (%" TCL_T_MODIFIER "d) invoking ", iPtr->numLevels, - (size_t)(pc - codePtr->codeStart)); + (pc - codePtr->codeStart)); } for (i = 0; i < opnd; i++) { TclPrintObject(stdout, objv[i], 15); @@ -5015,7 +5015,7 @@ TEBCresume( TRACE_APPEND(("\"%.30s\"", O2S(objResultPtr))); NEXT_INST_F(9, 1, 1); } - toIdx = TclIndexDecode(toIdx, objc - 1); + toIdx = TclIndexDecode((int)toIdx, objc - 1); if (toIdx == TCL_INDEX_NONE) { goto emptyList; } else if (toIdx >= objc) { @@ -5032,7 +5032,7 @@ TEBCresume( fromIdx = TCL_INDEX_START; } - fromIdx = TclIndexDecode(fromIdx, objc - 1); + fromIdx = TclIndexDecode((int)fromIdx, objc - 1); DECACHE_STACK_INFO(); if (TclObjTypeHasProc(valuePtr, sliceProc)) { @@ -5438,8 +5438,8 @@ TEBCresume( /* Decode index operands. */ - toIdx = TclIndexDecode(toIdx, slength - 1); - fromIdx = TclIndexDecode(fromIdx, slength - 1); + toIdx = TclIndexDecode((int)toIdx, slength - 1); + fromIdx = TclIndexDecode((int)fromIdx, slength - 1); if (toIdx == TCL_INDEX_NONE) { TclNewObj(objResultPtr); } else { @@ -9341,7 +9341,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; diff --git a/generic/tclIO.c b/generic/tclIO.c index bedf714..c884934 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -6073,8 +6073,8 @@ DoReadChars( * is available (Bug 73bb42fb3f). Either way need to break out * of the loop. */ - if (GotFlag(statePtr, CHANNEL_EOF) || - GotFlag(statePtr, CHANNEL_ENCODING_ERROR)) { + if (GotFlag(statePtr, CHANNEL_EOF) + || GotFlag(statePtr, CHANNEL_ENCODING_ERROR)) { break; } diff --git a/generic/tclInt.h b/generic/tclInt.h index d430164..10387a2 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3586,7 +3586,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, Tcl_Size line, Tcl_Size *clNextOuter, const char *outerScript); MODULE_SCOPE Tcl_Size TclTrim(const char *bytes, Tcl_Size numBytes, const char *trim, Tcl_Size numTrim, @@ -3995,7 +3995,7 @@ MODULE_SCOPE Tcl_Obj * TclPtrIncrObjVarIdx(Tcl_Interp *interp, 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, diff --git a/generic/tclInterp.c b/generic/tclInterp.c index 8276145..c873401 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -340,8 +340,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. */ diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index f817d29..4c6957c 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -180,7 +180,7 @@ static const DeclaredSlot slots[] = { * used with Tcl_ObjPrintf(). */ -#define PRIVATE_VARIABLE_PATTERN "%d : %s" +#define PRIVATE_VARIABLE_PATTERN "%" TCL_Z_MODIFIER "d : %s" /* * ---------------------------------------------------------------------- @@ -620,7 +620,7 @@ InstallPrivateVariableMapping( PrivateVariableList *pvlPtr, Tcl_Size varc, Tcl_Obj *const *varv, - int creationEpoch) + Tcl_Size creationEpoch) { PrivateVariableMapping *privatePtr; Tcl_Size i, n; @@ -3121,7 +3121,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/tclParse.c b/generic/tclParse.c index 872ccb5..f2589c4 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -2096,7 +2096,7 @@ 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. */ diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 72206d6..da5ca6c 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -803,7 +803,7 @@ TclGetRange( Tcl_Size first, /* First index of the range. */ Tcl_Size last) /* Last index of the range. */ { - Tcl_Obj *newObjPtr; /* The Tcl object to return that is the new + Tcl_Obj *newObjPtr; /* The Tcl object to return that is the new * range. */ Tcl_Size length = 0; diff --git a/generic/tclTest.c b/generic/tclTest.c index 3c30af5..5f8d2ae 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -952,7 +952,7 @@ AsyncHandlerProc( 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]; @@ -1011,7 +1011,7 @@ AsyncThreadProc( * TestAsyncHandler, defined above. */ { TestAsyncHandler *asyncPtr; - int id = PTR2INT(clientData); + int id = (int)PTR2INT(clientData); Tcl_Sleep(1); Tcl_MutexLock(&asyncTestMutex); @@ -1705,7 +1705,7 @@ DelCallbackProc( 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); @@ -5798,7 +5798,7 @@ TestsetCmd( 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) { @@ -5829,7 +5829,7 @@ Testset2Cmd( 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) { diff --git a/generic/tclTestABSList.c b/generic/tclTestABSList.c index 5971ca7..8552c9d 100644 --- a/generic/tclTestABSList.c +++ b/generic/tclTestABSList.c @@ -833,8 +833,8 @@ UpdateStringOfLString(Tcl_Obj *objPtr) 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; /* diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index b8da2f7..f3f8884 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -1670,7 +1670,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); @@ -1682,7 +1682,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); @@ -1840,8 +1840,8 @@ TestisemptyCmd ( { Tcl_Obj *result; if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "value"); - return TCL_ERROR; + Tcl_WrongNumArgs(interp, 1, objv, "value"); + return TCL_ERROR; } result = Tcl_NewIntObj(Tcl_IsEmpty(objv[1])); if (!objv[1]->bytes) { diff --git a/generic/tclVar.c b/generic/tclVar.c index 058bc70..54da881 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -223,7 +223,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; @@ -607,7 +607,7 @@ TclObjLookupVarEx( Var *varPtr; /* Points to the variable's in-frame Var * structure. */ const char *errMsg = NULL; - int index; + Tcl_Size index; int parsed = 0; Tcl_Size localIndex; @@ -832,7 +832,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; @@ -4618,7 +4618,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; diff --git a/win/tclWinChan.c b/win/tclWinChan.c index 5dad26a..ab847df 100644 --- a/win/tclWinChan.c +++ b/win/tclWinChan.c @@ -868,9 +868,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. @@ -913,7 +913,7 @@ FileGetOptionProc( { FileInfo *infoPtr = (FileInfo *)instanceData; int valid = 0; /* Flag if valid option parsed. */ - int len; + size_t len; if (optionName == NULL) { len = 0; diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index ce4f2b9..ec6d170 100644 --- a/win/tclWinConsole.c +++ b/win/tclWinConsole.c @@ -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. @@ -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(); @@ -1867,7 +1867,7 @@ ConsoleWriterThread( while (1) { /* handleInfoPtr->lock must be held on entry to loop */ - int offset; + Tcl_Size offset; HANDLE consoleHandle; /* @@ -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/tclWinFCmd.c b/win/tclWinFCmd.c index 723e8e9..5059291 100644 --- a/win/tclWinFCmd.c +++ b/win/tclWinFCmd.c @@ -1186,8 +1186,8 @@ TraverseWinTree( { DWORD sourceAttr; WCHAR *nativeSource, *nativeTarget, *nativeErrfile; - int result, found, sourceLen; - Tcl_Size oldSourceLen, oldTargetLen, targetLen = 0; + int result, found; + Tcl_Size sourceLen, oldSourceLen, oldTargetLen, targetLen = 0; HANDLE handle; WIN32_FIND_DATAW data; @@ -1262,7 +1262,7 @@ TraverseWinTree( found = 1; for (; found; found = FindNextFileW(handle, &data)) { WCHAR *nativeName; - int len; + size_t len; WCHAR *wp = data.cFileName; if (*wp == '.') { diff --git a/win/tclWinFile.c b/win/tclWinFile.c index 2203aef..7d95853 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; @@ -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 = @@ -1854,7 +1854,7 @@ static int NativeIsExec( const WCHAR *path) { - int len = wcslen(path); + size_t len = wcslen(path); if (len < 5) { return 0; @@ -2133,17 +2133,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; diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c index 2e96053..ae4f93f 100644 --- a/win/tclWinPipe.c +++ b/win/tclWinPipe.c @@ -3247,7 +3247,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/tclWinSock.c b/win/tclWinSock.c index 6771c39..df04783 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -1762,7 +1762,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 +1831,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 +2218,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); continue; diff --git a/win/tclWinTest.c b/win/tclWinTest.c index 72e1e83..eb9966b 100644 --- a/win/tclWinTest.c +++ b/win/tclWinTest.c @@ -568,7 +568,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)) { -- cgit v0.12 From 7bf96e00359b145f94d24fb67eb4b6117b3d2ae1 Mon Sep 17 00:00:00 2001 From: culler Date: Thu, 17 Apr 2025 14:58:00 +0000 Subject: Update macher version in onefiledist.yml so it will work with a thin macOS executable. --- .github/workflows/onefiledist.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/onefiledist.yml b/.github/workflows/onefiledist.yml index 69d3102..a1af478 100644 --- a/.github/workflows/onefiledist.yml +++ b/.github/workflows/onefiledist.yml @@ -72,7 +72,7 @@ jobs: run: | mkdir 1dist touch generic/tclStubInit.c generic/tclOOStubInit.c || true - wget https://github.com/culler/macher/releases/download/v1.3/macher + wget https://github.com/culler/macher/releases/download/v1.7/macher sudo cp macher /usr/local/bin sudo chmod a+x /usr/local/bin/macher echo "VER_PATH=$(cd tools; pwd)/addVerToFile.tcl" >> $GITHUB_ENV -- cgit v0.12 From f64464d18fe1824e8ed157c3e9e53ad34f3912ac Mon Sep 17 00:00:00 2001 From: culler Date: Thu, 17 Apr 2025 15:01:57 +0000 Subject: Update macher version in onefiledist.yml so it will work with a thin macOS executable. --- .github/workflows/onefiledist.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/onefiledist.yml b/.github/workflows/onefiledist.yml index 87c547e..e046cb4 100644 --- a/.github/workflows/onefiledist.yml +++ b/.github/workflows/onefiledist.yml @@ -72,7 +72,7 @@ jobs: run: | mkdir 1dist touch generic/tclStubInit.c generic/tclOOStubInit.c || true - wget https://github.com/culler/macher/releases/download/v1.3/macher + wget https://github.com/culler/macher/releases/download/v1.7/macher sudo cp macher /usr/local/bin sudo chmod a+x /usr/local/bin/macher echo "VER_PATH=$(cd tools; pwd)/addVerToFile.tcl" >> $GITHUB_ENV -- cgit v0.12 From 56c39ebf06efdfa02093eb55a2eb821c1460338b Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 17 Apr 2025 16:30:12 +0000 Subject: Fix up the handling of zero input to RequiredPrecision --- generic/tclStrToD.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index 3a6470e..a420552 100644 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -2314,7 +2314,7 @@ RequiredPrecision( unsigned int wi; if (sizeof(Tcl_WideUInt) <= sizeof(long long)) { - return 1 + ( w ? TclLog2((long long) w) : 0); + return w ? 1 + TclLog2((long long) w) : 0; } /* TODO: Are there any circumstances where we will continue -- cgit v0.12 From 3fcc1a8bb27b0aa2385c974ed779bec529bcdfc0 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 17 Apr 2025 16:41:41 +0000 Subject: Remove code that purports to handle the circumstance when sizeof(Tcl_WideUInt) > sizeof(long long) It is believed this is never true in Tcl 9. --- generic/tclStrToD.c | 35 ++--------------------------------- 1 file changed, 2 insertions(+), 33 deletions(-) diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index a420552..3faadb1 100644 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -2310,40 +2310,9 @@ static int RequiredPrecision( Tcl_WideUInt w) /* Number to interrogate. */ { - int rv; - unsigned int wi; + /* assert(sizeof(Tcl_WideUInt) <= sizeof(long long)) */ - if (sizeof(Tcl_WideUInt) <= sizeof(long long)) { - return w ? 1 + TclLog2((long long) w) : 0; - } - - /* TODO: Are there any circumstances where we will continue - * to the alternative below? */ - - if (w & ((Tcl_WideUInt)0xFFFFFFFF << 32)) { - wi = (unsigned int)(w >> 32); rv = 32; - } else { - wi = (unsigned int)w; rv = 0; - } - if (wi & 0xFFFF0000) { - wi >>= 16; rv += 16; - } - if (wi & 0xFF00) { - wi >>= 8; rv += 8; - } - if (wi & 0xF0) { - wi >>= 4; rv += 4; - } - if (wi & 0xC) { - wi >>= 2; rv += 2; - } - if (wi & 0x2) { - wi >>= 1; ++rv; - } - if (wi & 0x1) { - ++rv; - } - return rv; + return w ? 1 + TclLog2((long long) w) : 0; } /* -- cgit v0.12 From 9d702a3135cb699411125ddd50d9403ae116d688 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 17 Apr 2025 17:30:26 +0000 Subject: The callers of TclLog2() needed its range to be limited to [0..31]. RequiredPrecision needs support for the full long long range. Create a new utility routine TclMSB() to provide the functionality without truncated range. Use it. Put it internal stubs anticipating testing. --- generic/tclInt.decls | 4 ++++ generic/tclIntDecls.h | 8 +++++--- generic/tclStrToD.c | 2 +- generic/tclStubInit.c | 2 +- generic/tclUtil.c | 34 ++++++++++++++++++++++++++++++++++ 5 files changed, 45 insertions(+), 5 deletions(-) diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 7e5702c..86b2fe5 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -636,6 +636,10 @@ declare 257 { Tcl_LibraryInitProc *initProc, Tcl_LibraryInitProc *safeInitProc) } +declare 259 { + int TclMSB(unsigned long long n) +} + declare 261 { void TclUnusedStubEntry(void) } diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 6d9a09a..ffbd246 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -570,7 +570,8 @@ EXTERN void TclStaticLibrary(Tcl_Interp *interp, Tcl_LibraryInitProc *initProc, Tcl_LibraryInitProc *safeInitProc); /* Slot 258 is reserved */ -/* Slot 259 is reserved */ +/* 259 */ +EXTERN int TclMSB(unsigned long long n); /* Slot 260 is reserved */ /* 261 */ EXTERN void TclUnusedStubEntry(void); @@ -838,7 +839,7 @@ typedef struct TclIntStubs { int (*tclPtrUnsetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags); /* 256 */ void (*tclStaticLibrary) (Tcl_Interp *interp, const char *prefix, Tcl_LibraryInitProc *initProc, Tcl_LibraryInitProc *safeInitProc); /* 257 */ void (*reserved258)(void); - void (*reserved259)(void); + int (*tclMSB) (unsigned long long n); /* 259 */ void (*reserved260)(void); void (*tclUnusedStubEntry) (void); /* 261 */ } TclIntStubs; @@ -1253,7 +1254,8 @@ extern const TclIntStubs *tclIntStubsPtr; #define TclStaticLibrary \ (tclIntStubsPtr->tclStaticLibrary) /* 257 */ /* Slot 258 is reserved */ -/* Slot 259 is reserved */ +#define TclMSB \ + (tclIntStubsPtr->tclMSB) /* 259 */ /* Slot 260 is reserved */ #define TclUnusedStubEntry \ (tclIntStubsPtr->tclUnusedStubEntry) /* 261 */ diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index 3faadb1..3a81615 100644 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -2312,7 +2312,7 @@ RequiredPrecision( { /* assert(sizeof(Tcl_WideUInt) <= sizeof(long long)) */ - return w ? 1 + TclLog2((long long) w) : 0; + return w ? 1 + TclMSB((unsigned long long) w) : 0; } /* diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 74c709e..9c7aef2 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -674,7 +674,7 @@ static const TclIntStubs tclIntStubs = { TclPtrUnsetVar, /* 256 */ TclStaticLibrary, /* 257 */ 0, /* 258 */ - 0, /* 259 */ + TclMSB, /* 259 */ 0, /* 260 */ TclUnusedStubEntry, /* 261 */ }; diff --git a/generic/tclUtil.c b/generic/tclUtil.c index c28056d..7fa0b26 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -4611,6 +4611,40 @@ TclReToGlob( } /* + *---------------------------------------------------------------------- + * + * TclMSB -- + * + * Given a unsigned long long non-zero value n, return the index of + * the most significant bit in n that is set. This is equivalent to + * returning trunc(log2(n)). It's also equivalent to the largest + * integer k such that 2^k <= n. + * + * Results: + * The index of the most significant set bit in n, a value between + * 0 and CHAR_BIT*sizeof(unsigned long long) - 1, inclusive. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclMSB( + unsigned long long n) +{ + int k = 0; + + assert( n > 0); + + while (n >>= 1) { + k++; + } + return k; +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 -- cgit v0.12 From 2367b2f504a944ee047472c8fd2ca7398c79b5f7 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 17 Apr 2025 17:44:54 +0000 Subject: Re-implement TclLog2() in terms of TclMSB with range limiting wrapped around the core function. NOTE: TclLog2() was implemented incorrectly. As written it was never going to return values 23 through 30. It would falsely pin them up to 31. This bug is still present on the trunk, so will need fixing if this branch is not approved to merge. --- generic/tclExecute.c | 30 ++++-------------------------- 1 file changed, 4 insertions(+), 26 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 2c18e1e..fbc39d8 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -9562,32 +9562,10 @@ TclLog2( long long value) /* The integer for which to compute the log * base 2. The maximum output is 31 */ { - int result = 0; - - if (value > 0x7FFFFF) { - return 31; - } - if (value > 0xFFFF) { - value >>= 16; - result += 16; - } - if (value > 0xFF) { - value >>= 8; - result += 8; - } - if (value > 0xF) { - value >>= 4; - result += 4; - } - if (value > 0x3) { - value >>= 2; - result += 2; - } - if (value > 0x1) { - value >>= 1; - result++; - } - return result; + return (value > 0) ? ( + (value > 0x7FFFFFFF) ? + 31 : TclMSB((unsigned long long) value) + ) : 0; } #ifdef TCL_COMPILE_STATS -- cgit v0.12 From faee828d70072176716afcaa1bddc53ef3e17667 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 17 Apr 2025 20:09:26 +0000 Subject: off-by-8 (thanks, Don!) --- generic/tclExecute.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 202364a..774f190 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -9565,7 +9565,7 @@ TclLog2( { int result = 0; - if (value > 0x7FFFFF) { + if (value > 0x7FFFFFFF) { return 31; } if (value > 0xFFFF) { -- cgit v0.12 From 47e1f51328292780e2911c6da518cd560f6b76e3 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 17 Apr 2025 20:53:37 +0000 Subject: Fix warning: variables 'ui' and 'maxSizeDecade' used in loop condition not modified in loop body [-Wfor-loop-analysis] Remove unnecessary right-shift --- generic/tclExecute.c | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 774f190..69ec50c 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -9585,7 +9585,6 @@ TclLog2( result += 2; } if (value > 0x1) { - value >>= 1; result++; } return result; @@ -9938,7 +9937,7 @@ EvalStatsCmd( } maxSizeDecade = i; sum = 0; - for (ui = minSizeDecade; ui <= maxSizeDecade; i++) { + for (ui = minSizeDecade; ui <= maxSizeDecade; ui++) { decadeHigh = (1 << (ui+1)) - 1; sum += statsPtr->byteCodeCount[ui]; Tcl_AppendPrintfToObj(objPtr, "\t%10" TCL_SIZE_MODIFIER "d\t\t%8.0f%%\n", -- cgit v0.12 From f70603d910b1bb7c56458c12a97c0bf59472fe79 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 18 Apr 2025 09:22:14 +0000 Subject: Many more (harmless) -Wconversion fixes, mainly for the regexp engine --- generic/regc_color.c | 2 +- generic/regc_nfa.c | 14 +++++++------- generic/regcomp.c | 20 ++++++++++---------- generic/regexec.c | 4 ++-- generic/regguts.h | 2 +- generic/tclAssembly.c | 2 +- generic/tclBasic.c | 2 +- generic/tclIOCmd.c | 2 +- generic/tclIOGT.c | 7 ++++--- 9 files changed, 28 insertions(+), 27 deletions(-) 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 e20e271..e9c9c87 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 *); @@ -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 */ @@ -792,7 +792,7 @@ parseqatom( size_t m, n; struct subre *atom; /* atom's subtree */ struct subre *t; - int cap; /* capturing parens? */ + size_t cap; /* capturing parens? */ size_t pos; /* positive lookahead? */ size_t subno; /* capturing-parens or backref number */ int atomtype; @@ -1094,7 +1094,7 @@ parseqatom( if (atom != NULL) { freesubre(v, atom); } - top->flags = f; + top->flags = (char)f; return; } @@ -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; diff --git a/generic/regexec.c b/generic/regexec.c index a6170e9..04c812a 100644 --- a/generic/regexec.c +++ b/generic/regexec.c @@ -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 diff --git a/generic/regguts.h b/generic/regguts.h index c393cd8..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) */ - size_t 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/tclAssembly.c b/generic/tclAssembly.c index 6575934..cfb243e 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -66,7 +66,7 @@ typedef struct BasicBlock { * substituted with JUMP4's */ int startOffset; /* Instruction offset of the start of the * block */ - int startLine; /* Line number in the input script of the + Tcl_Size startLine; /* Line number in the input script of the * instruction at the start of the block */ int jumpOffset; /* Bytecode offset of the 'jump' instruction * that ends the block, or -1 if there is no diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 243009b..a146083 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -6105,7 +6105,7 @@ TclEvalObjEx( * 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. */ { int result = TCL_OK; NRE_callback *rootPtr = TOP_CB(interp); diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index 707039e..3e8b39a 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -1136,7 +1136,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. diff --git a/generic/tclIOGT.c b/generic/tclIOGT.c index f9a1d11..d855b73 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); /* @@ -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. */ @@ -637,7 +637,8 @@ TransformInputProc( int *errorCodePtr) { TransformChannelData *dataPtr = (TransformChannelData *)instanceData; - int gotBytes, read, copied; + int gotBytes, copied; + Tcl_Size read; Tcl_Channel downChan; /* -- cgit v0.12 From 6b33a12391bbb3062ceec478a3ad141ce75ebb97 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sat, 19 Apr 2025 11:41:18 +0000 Subject: Add an abstract list type for reversing lists --- generic/tclCmdIL.c | 72 +------------- generic/tclInt.h | 5 + generic/tclListTypes.c | 256 +++++++++++++++++++++++++++++++++++++++++++++++++ unix/Makefile.in | 6 +- win/Makefile.in | 1 + win/makefile.vc | 1 + 6 files changed, 271 insertions(+), 70 deletions(-) create mode 100644 generic/tclListTypes.c diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index b3d5fe9..a1ed01c 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -3157,82 +3157,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 8 */ /* diff --git a/generic/tclListTypes.c b/generic/tclListTypes.c new file mode 100644 index 0000000..c65c1c2 --- /dev/null +++ b/generic/tclListTypes.c @@ -0,0 +1,256 @@ +/* + * tclListTypes.c -- + * + * This file contains functions that implement the Tcl abstract list + * object types. + * + * Copyright © 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 +#include "tclInt.h" + +/* + *------------------------------------------------------------------------ + * + * 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 + int localFlags[LOCAL_SIZE], *flagPtr = NULL; + Tcl_Size numElems, i, length; + size_t bytesNeeded = 0; + 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 = (int *)Tcl_Alloc(numElems); + } + for (i = 0; i < numElems; i++) { + Tcl_Obj *elemObj; + 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 += Tcl_ScanCountedElement(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 - 1; + + /* + * Pass 2: copy into string rep buffer. + */ + + start = dst = (char *) Tcl_Alloc(bytesNeeded); + for (i = 0; i < numElems; i++) { + Tcl_Obj *elemObj; + 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 += Tcl_ConvertCountedElement(elem, length, dst, flagPtr[i]); + *dst++ = ' '; + } + dst[-1] = '\0'; // Overwrite last space + size_t finalLen = dst - start; + + /* 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 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 void LreverseFreeIntrep(Tcl_Obj *objPtr); +static void LreverseDupIntrep(Tcl_Obj *srcObj, Tcl_Obj *dupObj); +static Tcl_ObjTypeLengthProc LreverseTypeLength; +static Tcl_ObjTypeIndexProc LreverseTypeIndex; +static Tcl_ObjTypeReverseProc LreverseTypeReverse; + +static const Tcl_ObjType lreverseType = { + "lreverse", /* name */ + LreverseFreeIntrep, /* freeIntRepProc */ + LreverseDupIntrep, /* dupIntRepProc */ + TclAbstractListUpdateString, /* updateStringProc */ + NULL, /* setFromAnyProc */ + TCL_OBJTYPE_V2(LreverseTypeLength, /* lengthProc */ + LreverseTypeIndex, /* indexProc */ + NULL, /* sliceProc */ + LreverseTypeReverse, /* reverseProc */ + NULL, /* getElementsProc */ + NULL, /* setElementProc - TODO */ + NULL, /* replaceProc - TODO */ + NULL) /* inOperProc - TODO */ +}; + +void +LreverseFreeIntrep(Tcl_Obj *objPtr) +{ + Tcl_DecrRefCount((Tcl_Obj *)objPtr->internalRep.ptrAndSize.ptr); +} + +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 */ +Tcl_Size +LreverseTypeLength(Tcl_Obj *objPtr) +{ + return objPtr->internalRep.ptrAndSize.size; +} + +/* Implementation of Tcl_ObjType.indexProc for lreverseType */ +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 */ +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; +} + +/* + *------------------------------------------------------------------------ + * + * 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 *reversedPtrPtr. This may be the same as objPtr, + * 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. + * + *------------------------------------------------------------------------ + */ +int +Tcl_ListObjReverse( + Tcl_Interp *interp, + Tcl_Obj *objPtr, /* Source whose elements are to be reversed */ + Tcl_Obj **reversedPtrPtr) /* Location to store result object */ +{ + /* If the list is an AbstractList with a specialized reverse, use it. */ + if (TclObjTypeHasProc(objPtr, reverseProc)) { + if (TclObjTypeReverse(interp, objPtr, reversedPtrPtr) == TCL_OK) { + 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) { + return TCL_ERROR; + } + } + + /* If the list is empty, just return it. [Bug 1876793] */ + if (elemc == 0) { + *reversedPtrPtr = objPtr; + return TCL_OK; + } + + Tcl_Obj *resultPtr = Tcl_NewObj(); + Tcl_InvalidateStringRep(resultPtr); + + Tcl_IncrRefCount(objPtr); + resultPtr->internalRep.ptrAndSize.ptr = objPtr; + resultPtr->internalRep.ptrAndSize.size = elemc; + resultPtr->typePtr = &lreverseType; + *reversedPtrPtr = resultPtr; + return TCL_OK; +} diff --git a/unix/Makefile.in b/unix/Makefile.in index 9569b3b..3193b9b 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 \ @@ -1410,6 +1411,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 diff --git a/win/Makefile.in b/win/Makefile.in index 7a56163..f596834 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -334,6 +334,7 @@ GENERIC_OBJS = \ tclLink.$(OBJEXT) \ tclLiteral.$(OBJEXT) \ tclListObj.$(OBJEXT) \ + tclListTypes.$(OBJEXT) \ tclLoad.$(OBJEXT) \ tclMainW.$(OBJEXT) \ tclMain.$(OBJEXT) \ diff --git a/win/makefile.vc b/win/makefile.vc index 175c4b2..094c0fe 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -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 \ -- cgit v0.12 From 5530db2715e97fbc06d9b5b25f922d6f01c78530 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 19 Apr 2025 12:25:06 +0000 Subject: Finish -Wconversion warnings in regexp engine --- generic/regcomp.c | 12 ++++++------ generic/rege_dfa.c | 6 +++--- generic/regexec.c | 2 +- 3 files changed, 10 insertions(+), 10 deletions(-) diff --git a/generic/regcomp.c b/generic/regcomp.c index e9c9c87..e2ce122 100644 --- a/generic/regcomp.c +++ b/generic/regcomp.c @@ -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,7 +788,7 @@ parseqatom( { struct state *s; /* temporaries for new states */ struct state *s2; -#define ARCV(t, val) newarc(v->nfa, t, val, lp, rp) +#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; @@ -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); @@ -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); } /* 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 04c812a..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); -- cgit v0.12 From 4366d35d49c811cb52364bc8221b15beacd18548 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sun, 20 Apr 2025 07:49:51 +0000 Subject: Add abstract list type for lrepeat --- generic/tclCmdIL.c | 82 ++--------------- generic/tclInt.h | 10 ++- generic/tclListTypes.c | 238 +++++++++++++++++++++++++++++++++++++++++++++++-- 3 files changed, 244 insertions(+), 86 deletions(-) diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index a1ed01c..6eb5f93 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -2941,92 +2941,24 @@ Tcl_LrepeatObjCmd( 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 8 */ diff --git a/generic/tclListTypes.c b/generic/tclListTypes.c index c65c1c2..eccdaff 100644 --- a/generic/tclListTypes.c +++ b/generic/tclListTypes.c @@ -4,7 +4,7 @@ * This file contains functions that implement the Tcl abstract list * object types. * - * Copyright © 2025 Ashok P. Nadkarni. All rights reserved. + * 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. @@ -13,6 +13,78 @@ #include #include "tclInt.h" +static inline int +TclAbstractListLength(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Size *lengthPtr) +{ + int ret; + if (TclObjTypeHasProc(objPtr, lengthProc)) { + *lengthPtr = TclObjTypeLength(objPtr); + ret = TCL_OK; + } else { + ret = TclListObjLength(interp, objPtr, lengthPtr); + } + return ret; +} + +/* + * TclObjArray stores a reference counted Tcl_Obj array. + */ +typedef struct TclObjArray { + Tcl_Size refCount; /* Reference count */ + Tcl_Size nelems; /* Number of elements in the array */ + Tcl_Obj *elemPtrs[1]; /* 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 inline TclObjArray * +TclObjArrayNew(size_t nelems, Tcl_Obj * const elemPtrs[]) +{ + TclObjArray *arrayPtr = (TclObjArray *)Tcl_Alloc( + sizeof(TclObjArray) + (nelems - 1) * 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++; +} + +/* + * 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) { + for (Tcl_Size i = 0; i < arrayPtr->nelems; i++) { + Tcl_DecrRefCount(arrayPtr->elemPtrs[i]); + } + Tcl_Free(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; +} + /* *------------------------------------------------------------------------ * @@ -33,7 +105,7 @@ static void TclAbstractListUpdateString (Tcl_Obj *objPtr) { #define LOCAL_SIZE 64 - int localFlags[LOCAL_SIZE], *flagPtr = NULL; + char localFlags[LOCAL_SIZE], *flagPtr = NULL; Tcl_Size numElems, i, length; size_t bytesNeeded = 0; const char *elem; @@ -58,7 +130,7 @@ static void TclAbstractListUpdateString (Tcl_Obj *objPtr) flagPtr = localFlags; } else { - flagPtr = (int *)Tcl_Alloc(numElems); + flagPtr = (char *)Tcl_Alloc(numElems); } for (i = 0; i < numElems; i++) { Tcl_Obj *elemObj; @@ -66,7 +138,7 @@ static void TclAbstractListUpdateString (Tcl_Obj *objPtr) ret = Tcl_ListObjIndex(NULL, objPtr, i, &elemObj); assert(ret == TCL_OK); elem = Tcl_GetStringFromObj(elemObj, &length); - bytesNeeded += Tcl_ScanCountedElement(elem, length, flagPtr + i); + 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", @@ -76,7 +148,7 @@ static void TclAbstractListUpdateString (Tcl_Obj *objPtr) Tcl_BounceRefCount(elemObj); #endif } - bytesNeeded += numElems - 1; + bytesNeeded += numElems; /* Including trailing nul */ /* * Pass 2: copy into string rep buffer. @@ -89,11 +161,11 @@ static void TclAbstractListUpdateString (Tcl_Obj *objPtr) ret = Tcl_ListObjIndex(NULL, objPtr, i, &elemObj); assert(ret == TCL_OK); elem = Tcl_GetStringFromObj(elemObj, &length); - dst += Tcl_ConvertCountedElement(elem, length, dst, flagPtr[i]); + dst += TclConvertElement(elem, length, dst, flagPtr[i]); *dst++ = ' '; } - dst[-1] = '\0'; // Overwrite last space - size_t finalLen = dst - start; + 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)) { @@ -103,7 +175,7 @@ static void TclAbstractListUpdateString (Tcl_Obj *objPtr) } } objPtr->bytes = start; - objPtr->length = finalLen-1; // Exclude the trailing null + objPtr->length = finalLen-1; /* Exclude the trailing null */ if (flagPtr != localFlags) { Tcl_Free(flagPtr); @@ -126,6 +198,13 @@ static Tcl_ObjTypeLengthProc LreverseTypeLength; static Tcl_ObjTypeIndexProc LreverseTypeIndex; static Tcl_ObjTypeReverseProc LreverseTypeReverse; +/* + * 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 = { "lreverse", /* name */ LreverseFreeIntrep, /* freeIntRepProc */ @@ -254,3 +333,144 @@ Tcl_ListObjReverse( *reversedPtrPtr = resultPtr; return TCL_OK; } + +/* + * ------------------------------------------------------------------------ + * 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 void LrepeatFreeIntrep(Tcl_Obj *objPtr); +static void LrepeatDupIntrep(Tcl_Obj *srcObj, Tcl_Obj *dupObj); +static Tcl_ObjTypeLengthProc LrepeatTypeLength; +static Tcl_ObjTypeIndexProc LrepeatTypeIndex; + +/* + * IMPORTANT - current implementation is read-only. That is, the + * functions below that set or modify elements are not 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 = { + "lrepeat", /* 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 */ + NULL) /* inOperProc - TODO */ +}; + +void +LrepeatFreeIntrep(Tcl_Obj *objPtr) +{ + TclObjArrayUnref((TclObjArray *)objPtr->internalRep.ptrAndSize.ptr); +} + +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 */ +Tcl_Size +LrepeatTypeLength(Tcl_Obj *objPtr) +{ + return objPtr->internalRep.ptrAndSize.size; +} + +/* Implementation of Tcl_ObjType.indexProc for lrepeatType */ +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; +} + +/* + *------------------------------------------------------------------------ + * + * 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 the same as objPtr, + * 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. + * + *------------------------------------------------------------------------ + */ +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) { + 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 (repeatCount == 0) { + *resultPtrPtr = Tcl_NewObj(); + return TCL_OK; + } + + /* Final sanity check. Do not exceed limits on max list length. */ + if (objc > LIST_MAX/repeatCount) { + 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); + return TCL_ERROR; + } + + TclObjArray *arrayPtr = TclObjArrayNew(objc, objv); + Tcl_Obj *resultPtr = Tcl_NewObj(); + arrayPtr->refCount++; + Tcl_InvalidateStringRep(resultPtr); + resultPtr->internalRep.ptrAndSize.ptr = arrayPtr; + resultPtr->internalRep.ptrAndSize.size = repeatCount*objc; + resultPtr->typePtr = &lrepeatType; + *resultPtrPtr = resultPtr; + return TCL_OK; +} -- cgit v0.12 From 9a2719509cc03c18fac630eb1bb97e9ab0ff0b53 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 20 Apr 2025 12:01:05 +0000 Subject: Fix type. In at least one compiler, having the line number as int just blew up the build. It's an internal type too; no compat concerns with having it be Tcl_Size. --- generic/tclInt.h | 3 ++- generic/tclParse.c | 2 +- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 9455d8d..fe1c77b 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3586,7 +3586,8 @@ 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, Tcl_Size *tokensLeftPtr, int line, + Tcl_Size count, Tcl_Size *tokensLeftPtr, + Tcl_Size line, Tcl_Size *clNextOuter, const char *outerScript); MODULE_SCOPE Tcl_Size TclTrim(const char *bytes, Tcl_Size numBytes, const char *trim, Tcl_Size numTrim, diff --git a/generic/tclParse.c b/generic/tclParse.c index 7216e8e..f2589c4 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -2099,7 +2099,7 @@ TclSubstTokens( Tcl_Size *tokensLeftPtr, /* If not NULL, points to memory where an * integer representing the number of tokens * left to be substituted will be written */ - int line, /* The line the script starts on. */ + Tcl_Size 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 -- cgit v0.12 From eddf277649517b95ead8a300b46731e704005f40 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 20 Apr 2025 15:14:21 +0000 Subject: Fix the weirdest bug in the assembler with getting line numbers wrong... sometimes. I'm not even sure that the right thing was being done before... --- generic/tclAssembly.c | 33 ++++++++++++++++++++++++--------- 1 file changed, 24 insertions(+), 9 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 590ecea..3f437bd 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -164,6 +164,8 @@ typedef enum { * consumses N, produces 1 */ ASSEM_LSET_FLAT, /* 4-byte operand count, must be >= 3, * consumes N, produces 1 */ + 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 */ @@ -326,8 +328,8 @@ static const TalInstDesc TalInstructionTable[] = { {"push", ASSEM_PUSH, INST_PUSH, 0, 1}, {"add", ASSEM_1BYTE, INST_ADD, 2, 1}, - {"append", ASSEM_LVT, INST_APPEND_SCALAR, 1, 1}, - {"appendArray", ASSEM_LVT, INST_APPEND_ARRAY, 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_LVT, INST_ARRAY_EXISTS_IMM, 0, 1}, @@ -395,8 +397,8 @@ static const TalInstDesc TalInstructionTable[] = { // For legacy code {"jumpTrue4", ASSEM_JUMP, INST_JUMP_TRUE, 1, 0}, {"label", ASSEM_LABEL, 0, 0, 0}, - {"lappend", ASSEM_LVT, INST_LAPPEND_SCALAR, 1, 1}, - {"lappendArray", ASSEM_LVT, INST_LAPPEND_ARRAY, 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_LVT, INST_LAPPEND_LIST, 1, 1}, {"lappendListArray",ASSEM_LVT, INST_LAPPEND_LIST_ARRAY,2, 1}, @@ -413,8 +415,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_SCALAR, 0, 1}, - {"loadArray", ASSEM_LVT, INST_LOAD_ARRAY, 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}, @@ -439,8 +441,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_SCALAR, 1, 1}, - {"storeArray", ASSEM_LVT, INST_STORE_ARRAY, 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}, @@ -662,7 +664,19 @@ BBEmitOpcode( */ if (bbPtr->startOffset == CurrentOffset(envPtr)) { - bbPtr->startLine = assemEnvPtr->cmdLine; + 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); @@ -1578,6 +1592,7 @@ AssembleOneLine( TclEmitInt1(opnd, envPtr); break; + case ASSEM_LVT_N: case ASSEM_LVT: if (parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "varName"); -- cgit v0.12 From 07df807261af92ac86e7c48495ebfd1edab57234 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 20 Apr 2025 16:58:24 +0000 Subject: VarHashCreateVar() isn't used in tclExecute.c --- generic/tclExecute.c | 13 ++++--------- 1 file changed, 4 insertions(+), 9 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 69ec50c..ad09f47 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -155,22 +155,17 @@ typedef struct { ((Var *) ((char *)hPtr - offsetof(VarInHash, entry))) static inline Var * -VarHashCreateVar( +VarHashFindVar( TclVarHashTable *tablePtr, - Tcl_Obj *key, - int *newPtr) + Tcl_Obj *key) { - Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(&tablePtr->table, - key, newPtr); - + Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&tablePtr->table, + key); if (!hPtr) { return NULL; } return VarHashGetValue(hPtr); } - -#define VarHashFindVar(tablePtr, key) \ - VarHashCreateVar((tablePtr), (key), NULL) /* * The new macro for ending an instruction; note that a reasonable C-optimiser -- cgit v0.12 From 74bb80deb645d87fcd83daa1ec19e6e6be0d9021 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Mon, 21 Apr 2025 04:08:54 +0000 Subject: Use abstract lists only above a element count threshold --- generic/tclListTypes.c | 111 ++++++++++++++++++++++++++++++++++++++++++------- 1 file changed, 97 insertions(+), 14 deletions(-) diff --git a/generic/tclListTypes.c b/generic/tclListTypes.c index eccdaff..714086c 100644 --- a/generic/tclListTypes.c +++ b/generic/tclListTypes.c @@ -13,6 +13,14 @@ #include #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 + static inline int TclAbstractListLength(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Size *lengthPtr) { @@ -323,13 +331,43 @@ Tcl_ListObjReverse( return TCL_OK; } - Tcl_Obj *resultPtr = Tcl_NewObj(); - Tcl_InvalidateStringRep(resultPtr); + Tcl_Obj *resultPtr; + if (elemc >= LREVERSE_LENGTH_THRESHOLD || objPtr->typePtr != &tclListType) { + resultPtr = Tcl_NewObj(); + 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) { + return TCL_ERROR; + } + resultPtr = Tcl_NewListObj(elemc, NULL); + Tcl_Obj **dataArray = NULL; + ListRep listRep; + ListObjGetRep(resultPtr, &listRep); + dataArray = ListRepElementsBase(&listRep); + CLANG_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]; + } - Tcl_IncrRefCount(objPtr); - resultPtr->internalRep.ptrAndSize.ptr = objPtr; - resultPtr->internalRep.ptrAndSize.size = elemc; - resultPtr->typePtr = &lreverseType; *reversedPtrPtr = resultPtr; return TCL_OK; } @@ -451,7 +489,8 @@ Tcl_ListObjRepeat( return TCL_ERROR; } - if (repeatCount == 0) { + Tcl_Size totalElems = objc * repeatCount; + if (totalElems == 0) { *resultPtrPtr = Tcl_NewObj(); return TCL_OK; } @@ -464,13 +503,57 @@ Tcl_ListObjRepeat( return TCL_ERROR; } - TclObjArray *arrayPtr = TclObjArrayNew(objc, objv); - Tcl_Obj *resultPtr = Tcl_NewObj(); - arrayPtr->refCount++; - Tcl_InvalidateStringRep(resultPtr); - resultPtr->internalRep.ptrAndSize.ptr = arrayPtr; - resultPtr->internalRep.ptrAndSize.size = repeatCount*objc; - resultPtr->typePtr = &lrepeatType; + Tcl_Obj *resultPtr; + if (totalElems >= LREPEAT_LENGTH_THRESHOLD) { + TclObjArray *arrayPtr = TclObjArrayNew(objc, objv); + resultPtr = Tcl_NewObj(); + arrayPtr->refCount++; + TclInvalidateStringRep(resultPtr); + resultPtr->internalRep.ptrAndSize.ptr = arrayPtr; + resultPtr->internalRep.ptrAndSize.size = totalElems; + resultPtr->typePtr = &lrepeatType; + *resultPtrPtr = resultPtr; + return TCL_OK; + } + + /* For small lists, create a copy as indexing is slightly faster */ + resultPtr = Tcl_NewListObj(totalElems, NULL); + Tcl_Obj **dataArray = NULL; + if (totalElems) { + 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. + */ + + CLANG_ASSERT(dataArray || totalElems == 0 ); + if (objc == 1) { + Tcl_Obj *tmpPtr = objv[0]; + + tmpPtr->refCount += repeatCount; + for (Tcl_Size i=0 ; i Date: Mon, 21 Apr 2025 08:30:11 +0000 Subject: remove junk whitespace --- generic/tclCompCmds.c | 15 +++++++-------- generic/tclCompCmdsGR.c | 6 +++--- generic/tclCompUtils.h | 2 +- generic/tclCompile.h | 6 +++--- 4 files changed, 14 insertions(+), 15 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index f0ede97..4f1262a 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -43,7 +43,6 @@ static inline void IssueDictWithEmpty(Tcl_Interp *interp, 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. @@ -2047,7 +2046,7 @@ IsEmptyToken( { 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); @@ -2164,13 +2163,13 @@ IssueDictWithEmpty( gotPath = (numWords > 3); dictVar = LocalScalarFromToken(varTokenPtr, envPtr); - + if (dictVar >= 0) { if (gotPath) { /* * Case: Path into dict in LVT with empty body. */ - + tokenPtr = TokenAfter(varTokenPtr); for (i=2 ; i 3); dictVar = LocalScalarFromToken(varTokenPtr, envPtr); - + if (dictVar == -1) { varNameTmp = AnonymousLocal(envPtr); } diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 3025486..986bb47 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -1333,7 +1333,7 @@ TclCompileLinsertCmd( /* Push list, insertion index onto the stack */ listToken = TokenAfter(parsePtr->tokenPtr); indexToken = TokenAfter(listToken); - + PUSH_TOKEN( listToken, 1); PUSH_TOKEN( indexToken, 2); @@ -1386,11 +1386,11 @@ TclCompileLreplaceCmd( 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 */ tokenPtr = TokenAfter(lastToken); for (i=4; icodeNext++ = UCHAR(i ); // Emit 1-byte argument *envPtr->codeNext++ = UCHAR(j ); - + TclUpdateAtCmdStart(op, envPtr); TclUpdateStackReqs(op, i, envPtr); } @@ -1555,7 +1555,7 @@ TclEmitInstInt44Impl( if (envPtr->codeNext + 9 > envPtr->codeEnd) { TclExpandCodeArray(envPtr); } - + *envPtr->codeNext++ = UCHAR(op); // Emit 4-byte argument *envPtr->codeNext++ = UCHAR(i >> 24); @@ -1567,7 +1567,7 @@ TclEmitInstInt44Impl( *envPtr->codeNext++ = UCHAR(j >> 16); *envPtr->codeNext++ = UCHAR(j >> 8); *envPtr->codeNext++ = UCHAR(j ); - + TclUpdateAtCmdStart(op, envPtr); TclUpdateStackReqs(op, i, envPtr); } -- cgit v0.12 From 8058b22442423e86c90aa266f18e0a8a9dda9f7d Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 21 Apr 2025 15:37:21 +0000 Subject: Factor out some clock-related constants into their own enum --- generic/tclClock.c | 6 +++--- generic/tclCompCmds.c | 6 +++--- generic/tclExecute.c | 8 ++++---- generic/tclInt.h | 11 +++++++++++ 4 files changed, 21 insertions(+), 10 deletions(-) diff --git a/generic/tclClock.c b/generic/tclClock.c index ecba0c5..c314a54 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", diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 4f1262a..a12f969 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -767,7 +767,7 @@ TclCompileClockClicksCmd( /* * No args */ - OP1( CLOCK_READ, 0); + OP1( CLOCK_READ, CLOCK_READ_CLICKS); break; case 2: /* @@ -775,9 +775,9 @@ TclCompileClockClicksCmd( */ tokenPtr = TokenAfter(parsePtr->tokenPtr); if (IS_TOKEN_PREFIX(tokenPtr, 3, "-microseconds")) { - OP1( CLOCK_READ, 1); + OP1( CLOCK_READ, CLOCK_READ_MICROS); } else if (IS_TOKEN_PREFIX(tokenPtr, 3, "-milliseconds")) { - OP1( CLOCK_READ, 2); + OP1( CLOCK_READ, CLOCK_READ_MILLIS); } else { return TCL_ERROR; } diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 54b6cb8..79da8ba 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -7703,22 +7703,22 @@ TEBCresume( Tcl_WideInt wval; Tcl_Time now; switch (TclGetUInt1AtPtr(pc + 1)) { - case 0: /* clicks */ + case CLOCK_READ_CLICKS: /* clicks */ #ifdef TCL_WIDE_CLICKS wval = TclpGetWideClicks(); #else wval = (Tcl_WideInt)TclpGetClicks(); #endif break; - case 1: /* microseconds */ + case CLOCK_READ_MICROS: /* microseconds */ Tcl_GetTime(&now); wval = (Tcl_WideInt)now.sec * 1000000 + now.usec; break; - case 2: /* milliseconds */ + case CLOCK_READ_MILLIS: /* milliseconds */ Tcl_GetTime(&now); wval = (Tcl_WideInt)now.sec * 1000 + now.usec / 1000; break; - case 3: /* seconds */ + case CLOCK_READ_SECS: /* seconds */ Tcl_GetTime(&now); wval = (Tcl_WideInt)now.sec; break; diff --git a/generic/tclInt.h b/generic/tclInt.h index 83a292e..a482229 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3223,6 +3223,17 @@ 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: *---------------------------------------------------------------- -- cgit v0.12 From cf0978ad989cd77cbff4faa5c328359c1115632e Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 21 Apr 2025 16:52:17 +0000 Subject: Generate correct arguments to INST_TAILCALL so we don't need to patch them in TEBC --- generic/tclCompCmdsSZ.c | 4 +--- generic/tclExecute.c | 12 ++++++++---- 2 files changed, 9 insertions(+), 7 deletions(-) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 6f06bb7..d2ab409 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -2612,9 +2612,7 @@ TclCompileTailcallCmd( return TCL_ERROR; } - /* make room for the nsObjPtr */ - /* TODO: Doesn't this have to be a known value? */ - PUSH_TOKEN( tokenPtr, 0); + OP( NS_CURRENT); for (i=1 ; ivarFramePtr->nsPtr)); + Tcl_Obj *listPtr = Tcl_NewListObj(opnd, &OBJ_AT_DEPTH(opnd - 1)); +#ifndef REMOVE_DEPRECATED_OPCODES + /* New instruction sequence just gets this right. */ + if (inst == INST_TAILCALL1) { + TclListObjSetElement(NULL, listPtr, 0, TclNewNamespaceObj( + TclGetCurrentNamespace(interp))); + } +#endif if (iPtr->varFramePtr->tailcallPtr) { Tcl_DecrRefCount(iPtr->varFramePtr->tailcallPtr); } -- cgit v0.12 From 443637dcd2ee83349561d009bd75e3890b539f3c Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 22 Apr 2025 14:59:18 +0000 Subject: Better comments --- generic/tclCompCmds.c | 26 ++++++++++++-------------- 1 file changed, 12 insertions(+), 14 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index a12f969..973dac8 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -2135,7 +2135,13 @@ TclCompileDictWithCmd( return TCL_OK; } -/* Issue code for a [dict with] that has an entirely trivial body. */ +/* + * 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, @@ -2143,14 +2149,6 @@ IssueDictWithEmpty( Tcl_Token *varTokenPtr, CompileEnv *envPtr) { - /* - * 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. - */ - Tcl_Token *tokenPtr; DefineLineInformation; /* TIP #280 */ int gotPath; @@ -2226,7 +2224,11 @@ IssueDictWithEmpty( PUSH( ""); } -/* Issue code for a [dict with] that has a non-trivial body. */ +/* + * 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, @@ -2235,10 +2237,6 @@ IssueDictWithBodied( 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. */ -- cgit v0.12 From ce3e961fed242747dbcd2012017ad3893ce15506 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 22 Apr 2025 15:16:56 +0000 Subject: Make [switch -exact -nocase] compiled --- generic/tclCompCmdsSZ.c | 27 ++++++++++++++++++--------- 1 file changed, 18 insertions(+), 9 deletions(-) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index d2ab409..80704c1 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -66,7 +66,7 @@ static void IssueSwitchChainedTests(Tcl_Interp *interp, CompileEnv *envPtr, int mode, int noCase, Tcl_Size numArms, SwitchArmInfo *arms); static void IssueSwitchJumpTable(Tcl_Interp *interp, - CompileEnv *envPtr, Tcl_Size numArms, + CompileEnv *envPtr, int noCase, Tcl_Size numArms, SwitchArmInfo *arms); static int IssueTryClausesInstructions(Tcl_Interp *interp, CompileEnv *envPtr, Tcl_Token *bodyToken, @@ -1876,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. @@ -2053,7 +2046,7 @@ TclCompileSwitchCmd( PUSH_TOKEN( valueTokenPtr, valueIndex); if (mode == Switch_Exact) { - IssueSwitchJumpTable(interp, envPtr, numWords/2, arms); + IssueSwitchJumpTable(interp, envPtr, noCase, numWords/2, arms); } else { IssueSwitchChainedTests(interp, envPtr, mode, noCase, numWords/2, arms); } @@ -2318,6 +2311,7 @@ static void IssueSwitchJumpTable( Tcl_Interp *interp, /* Context for compiling script bodies. */ CompileEnv *envPtr, /* Holds resulting instructions. */ + int noCase, /* Whether to do case-insensitive matches. */ Tcl_Size numArms, /* Number of arms of the switch. */ SwitchArmInfo *arms) /* Array of arm descriptors. */ { @@ -2330,6 +2324,14 @@ IssueSwitchJumpTable( 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 * hashtable that maps from literal values to match against to the offset * (relative to the INST_JUMP_TABLE instruction) to jump to. The jump @@ -2375,10 +2377,17 @@ IssueSwitchJumpTable( * 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, arm->valueToken); + if (noCase) { + Tcl_Size slength = Tcl_UtfToLower(Tcl_DStringValue(&buffer)); + Tcl_DStringSetLength(&buffer, slength); + } hPtr = Tcl_CreateHashEntry(&jtPtr->hashTable, Tcl_DStringValue(&buffer), &isNew); if (isNew) { -- cgit v0.12 From 5ea2ee0bfbf5deb8a7ea50eabddb391c3dcd54c9 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 22 Apr 2025 16:30:58 +0000 Subject: Restore TclLog2() status to be available only for --enable-symbols=compile --- generic/tclCompile.h | 1 + generic/tclExecute.c | 2 +- generic/tclInt.h | 1 - 3 files changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclCompile.h b/generic/tclCompile.h index b3692aa..c4b6f65 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -1154,6 +1154,7 @@ MODULE_SCOPE void TclFinalizeLoopExceptionRange(CompileEnv *envPtr, int 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, CompileEnv *envPtr); diff --git a/generic/tclExecute.c b/generic/tclExecute.c index fbc39d8..74a6207 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -9539,6 +9539,7 @@ TclExprFloatError( } } +#ifdef TCL_COMPILE_STATS /* *---------------------------------------------------------------------- * @@ -9568,7 +9569,6 @@ TclLog2( ) : 0; } -#ifdef TCL_COMPILE_STATS /* *---------------------------------------------------------------------- * diff --git a/generic/tclInt.h b/generic/tclInt.h index 134c496..d430164 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3436,7 +3436,6 @@ MODULE_SCOPE Tcl_Obj * TclLsetList(Tcl_Interp *interp, Tcl_Obj *listPtr, MODULE_SCOPE Tcl_Obj * TclLsetFlat(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Size indexCount, Tcl_Obj *const indexArray[], Tcl_Obj *valuePtr); -MODULE_SCOPE int TclLog2(long long value); 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, -- cgit v0.12 From a54a0757a8b1153bed3efcbd930fa9a4e90d11a7 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 22 Apr 2025 16:50:34 +0000 Subject: Bring over testing command and tests for TclMSB() from dgp-refactor branch. --- generic/tclTest.c | 49 ++++++++++++++++++++++++++++++++++++++++++ tests/brodnik.test | 62 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 111 insertions(+) create mode 100644 tests/brodnik.test diff --git a/generic/tclTest.c b/generic/tclTest.c index 3c30af5..4faa1fb 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -251,6 +251,7 @@ static Tcl_ObjCmdProc TestlinkarrayCmd; static Tcl_ObjCmdProc TestlistrepCmd; static Tcl_ObjCmdProc TestlocaleCmd; static Tcl_ObjCmdProc TestmainthreadCmd; +static Tcl_ObjCmdProc TestmsbObjCmd; static Tcl_ObjCmdProc TestsetmainloopCmd; static Tcl_ObjCmdProc TestexitmainloopCmd; static Tcl_ObjCmdProc TestpanicCmd; @@ -647,6 +648,7 @@ Tcltest_Init( Tcl_CreateObjCommand(interp, "testlistrep", TestlistrepCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testlocale", TestlocaleCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "testmsb", TestmsbObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testpanic", TestpanicCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testparseargs", TestparseargsCmd,NULL,NULL); Tcl_CreateObjCommand(interp, "testparser", TestparserCmd, @@ -3998,6 +4000,53 @@ CleanupTestSetassocdataTests( /* *---------------------------------------------------------------------- * + * TestmsbObjCmd -- + * + * This procedure implements the "testmsb" command. It is + * used for testing the TclMSB() routine. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestmsbObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* The argument objects. */ +{ + Tcl_WideInt w = 0; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "integer"); + return TCL_ERROR; + } + if (sizeof(Tcl_WideUInt) <= sizeof(size_t)) { + if (TCL_OK != Tcl_GetWideIntFromObj(interp, objv[1], &w)) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewIntObj(TclMSB(w))); + } else { + int i; + if (TCL_OK != Tcl_GetIntFromObj(interp, objv[1], &i)) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewIntObj(TclMSB(i))); + } + return TCL_OK; + + (void)clientData; +} + +/* + *---------------------------------------------------------------------- + * * TestparserCmd -- * * This procedure implements the "testparser" command. It is diff --git a/tests/brodnik.test b/tests/brodnik.test new file mode 100644 index 0000000..b00808e --- /dev/null +++ b/tests/brodnik.test @@ -0,0 +1,62 @@ +# This file contains a collection of tests for the procedures in the +# file tclBrodnik.c. +# +# Contributions from Don Porter, NIST, 2013. (not subject to US copyright) +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +package require Tcl 8.6- +package require tcltest 2 + +namespace eval ::tcl::test::brodnik { + namespace import ::tcltest::loadTestedCommands + namespace import ::tcltest::testConstraint + namespace import ::tcltest::test + namespace import ::tcltest::cleanupTests + + loadTestedCommands + try {package require tcl::test} + testConstraint testmsb [expr {[namespace which -command testmsb] ne {}}] + + namespace eval tcl { + namespace eval mathfunc { + proc log2 {i} { + set k 0 + while {[set i [expr {$i>>1}]]} { + incr k + } + return $k + } + } + } + + # Tests for values with MSB in the low block + variable v 0 + while {$v < 1<<8} { + test brodnik-1.$v {TclMSB correctness} testmsb { + testmsb $v + } [expr {int(log2($v))}] + incr v + } + + variable i 8 + while {$i < 8*$::tcl_platform(pointerSize) - 1} { + + variable j -1 + while {$j < 2} { + set v [expr {(1<<$i) + $j}] + + test brodnik-2.$i.$j {TclMSB correctness} testmsb { + testmsb $v + } [expr {int(log2($v))}] + + incr j + } + incr i + } + + cleanupTests +} +namespace delete ::tcl::test::brodnik +return -- cgit v0.12 From ee58b4b2267dd25e0e1ec84bd0869f6206b563c0 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 22 Apr 2025 17:00:18 +0000 Subject: Update testing to Tcl 9 guarantees and conventions. --- generic/tclTest.c | 18 ++++-------------- tests/brodnik.test | 4 ++-- 2 files changed, 6 insertions(+), 16 deletions(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index 4faa1fb..58b15f1 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -4016,7 +4016,7 @@ CleanupTestSetassocdataTests( static int TestmsbObjCmd( - ClientData clientData, /* Not used. */ + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ @@ -4027,21 +4027,11 @@ TestmsbObjCmd( Tcl_WrongNumArgs(interp, 1, objv, "integer"); return TCL_ERROR; } - if (sizeof(Tcl_WideUInt) <= sizeof(size_t)) { - if (TCL_OK != Tcl_GetWideIntFromObj(interp, objv[1], &w)) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, Tcl_NewIntObj(TclMSB(w))); - } else { - int i; - if (TCL_OK != Tcl_GetIntFromObj(interp, objv[1], &i)) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, Tcl_NewIntObj(TclMSB(i))); + if (TCL_OK != Tcl_GetWideIntFromObj(interp, objv[1], &w)) { + return TCL_ERROR; } + Tcl_SetObjResult(interp, Tcl_NewIntObj(TclMSB((unsigned long long)w))); return TCL_OK; - - (void)clientData; } /* diff --git a/tests/brodnik.test b/tests/brodnik.test index b00808e..e3d9ed3 100644 --- a/tests/brodnik.test +++ b/tests/brodnik.test @@ -1,5 +1,5 @@ -# This file contains a collection of tests for the procedures in the -# file tclBrodnik.c. +# This file contains a collection of tests for the routine TclMSB() in the +# file tclUtil.c. # # Contributions from Don Porter, NIST, 2013. (not subject to US copyright) # -- cgit v0.12 From 18b33c63ada236b5e57230efd495f55eec98a7a6 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 22 Apr 2025 17:12:23 +0000 Subject: Port the Brodnik adaptation implementaton of TclMSB() from dgp-refactor branch --- generic/tclUtil.c | 159 +++++++++++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 153 insertions(+), 6 deletions(-) diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 7fa0b26..a927d88 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -4620,6 +4620,14 @@ TclReToGlob( * returning trunc(log2(n)). It's also equivalent to the largest * integer k such that 2^k <= n. * + * This routine is adapted from Andrej Brodnik, "Computation of the + * Least Significant Set Bit", pp 7-10, Proceedings of the 2nd + * Electrotechnical and Computer Science Conference, Portoroz, + * Slovenia, 1993. The adaptations permit the computation to take + * place within unsigned long long values without the need for double + * length buffers for calculation. They also fill in a number of + * details the paper omits or leaves unclear. + * * Results: * The index of the most significant set bit in n, a value between * 0 and CHAR_BIT*sizeof(unsigned long long) - 1, inclusive. @@ -4634,16 +4642,155 @@ int TclMSB( unsigned long long n) { - int k = 0; + /* Bits in an unsigned long long */ + const int M = CHAR_BIT * sizeof(unsigned long long); + + if (M == 64) { + + /* + * For a byte, consider two masks, C1 = 10000000 selecting just + * the high bit, and C2 = 01111111 selecting all other bits. + * Then for any byte value n, the computation + * LEAD(n) = C1 & (n | (C2 + (n & C2))) + * will leave all bits but the high bit unset, and will have the + * high bit set iff n!=0. The whole thing is an 8-bit test + * for being non-zero. For an 8-byte size_t, each byte can have + * the test applied all at once, with combined masks. + */ + const size_t C1 = 0x8080808080808080; + const size_t C2 = 0x7F7F7F7F7F7F7F7F; +#define LEAD(n) (C1 & (n | (C2 + (n & C2)))) + + /* + * To shift a bit to a new place, multiplication by 2^k will do. + * To shift the top 7 bits produced by the LEAD test to the high + * 7 bits of the entire size_t, multiply by the right sum of + * powers of 2. In this case + * Q = 1 + 2^7 + 2^14 + 2^21 + 2^28 + 2^35 + 2^42 + * Then shift those 7 bits down to the low 7 bits of the size_t. + * The key to making this work is that none of the shifted bits + * collide with each other in the top 7-bit destination. + * Note that we lose the bit that indicates whether the low byte + * is non-zero. That doesn't matter because we require the original + * value n to be non-zero, so if all other bytes signal to be zero, + * we know the low byte is non-zero, and if one of the other bytes + * signals non-zero, we just don't care what the low byte is. + */ + const size_t Q = 0x0000040810204081; + + /* + * To place a copy of a 7-bit value in each of 7 bytes in + * a size_t, just multply by the right value. In this case + * P = 0x00 01 01 01 01 01 01 01 + * We don't put a copy in the high byte since analysis of the + * remaining steps in the algorithm indicates we do not need it. + */ + const size_t P = 0x0001010101010101; + + /* + * With 7 copies of the LEAD value, we can now apply 7 masks + * to it in a single step by an & against the right value. + * B = 00000000 01111111 01111110 01111100 + * 01111000 01110000 01100000 01000000 + * The higher the MSB of the copied value is, the more of the + * B-masked bytes stored in t will be non-zero. + */ + const size_t B = 0x007F7E7C78706040; + size_t t = B & P * (LEAD(n) * Q >> 57); + + /* + * We want to get a count of the non-zero bytes stored in t. + * First use LEAD(t) to create a set of high bits signaling + * non-zero values as before. Call this value + * X = x6*2^55 +x5*2^47 +x4*2^39 +x3*2^31 +x2*2^23 +x1*2^15 +x0*2^7 + * Then notice what multiplication by + * P = 2^48 + 2^40 + 2^32 + 2^24 + 2^16 + 2^8 + 1 + * produces: + * P*X = x0*2^7 + (x0 + x1)*2^15 + ... + * ... + (x0 + x1 + x2 + x3 + x4 + x5 + x6) * 2^55 + ... + * ... + (x5 + x6)*2^95 + x6*2^103 + * The high terms of this product are going to overflow the size_t + * and get lost, but we don't care about them. What we care is that + * the 2^55 term is exactly the sum we seek. We shift the product + * down by 55 bits and then mask away all but the bottom 3 bits + * (Max sum can be 7) we get exactly the count of non-zero B-masked + * bytes. By design of the mask, this count is the index of the + * MSB of the LEAD value. It indicates which byte of the original + * value contains the MSB of the original value. + */ +#define SUM(t) (0x7 & (int)(LEAD(t) * P >> 55)); + + /* + * Multiply by 8 to get the number of bits to shift to place + * that MSB-containing byte in the low byte. + */ + int k = 8 * SUM(t); + + /* + * Shift the MSB byte to the low byte. Then shift one more bit. + * Since we know the MSB byte is non-zero we only need to compute + * the MSB of the top 7 bits. If all top 7 bits are zero, we know + * the bottom bit is the 1 and the correct index is 0. Compute the + * MSB of that value by the same steps we did before. + */ + t = B & P * (n >> k >> 1); + + /* + * Add the index of the MSB of the byte to the index of the low + * bit of that byte computed before to get the final answer. + */ + return k + SUM(t); + + /* Total operations: 33 + * 10 bit-ands, 6 multiplies, 4 adds, 5 rightshifts, + * 3 assignments, 3 bit-ors, 2 typecasts. + * + * The whole task is one direct computation. + * No branches. No loops. + * + * 33 operations cannot beat one instruction, so assembly + * wins and should be used wherever possible, but this isn't bad. + */ + +#undef SUM + } else if (M == 32) { + + /* Same scheme as above, with adjustments to the 32-bit size */ + const size_t C1 = 0xA0820820; + const size_t C2 = 0x5F7DF7DF; + const size_t C3 = 0xC0820820; + const size_t C4 = 0x20000000; + const size_t Q = 0x00010841; + const size_t P = 0x01041041; + const size_t B = 0x1F79C610; - assert( n > 0); +#define SUM(t) (0x7 & (LEAD(t) * P >> 29)); - while (n >>= 1) { - k++; + size_t t = B & P * ((C3 & (LEAD(n) + C4)) * Q >> 27); + int k = 6 * SUM(t); + + t = B & P * (n >> k >> 1); + return k + SUM(t); + + /* Total operations: 33 + * 11 bit-ands, 6 multiplies, 5 adds, 5 rightshifts, + * 3 assignments, 3 bit-ors. + */ + +#undef SUM +#undef LEAD + + } else { + /* Simple and slow fallback for cases we haven't done yet. */ + int k = 0; + + while (n >>= 1) { + k++; + } + return k; } - return k; } - + /* * Local Variables: * mode: c -- cgit v0.12 From cd11dabef89ba00a91b5b0df188b501befb76c2c Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 22 Apr 2025 17:26:41 +0000 Subject: Apply Tcl 9 guarantees and conventions. --- generic/tclUtil.c | 64 +++++++++++-------------------------------------------- 1 file changed, 13 insertions(+), 51 deletions(-) diff --git a/generic/tclUtil.c b/generic/tclUtil.c index a927d88..faabe07 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -4630,7 +4630,7 @@ TclReToGlob( * * Results: * The index of the most significant set bit in n, a value between - * 0 and CHAR_BIT*sizeof(unsigned long long) - 1, inclusive. + * 0 and 63, inclusive. * * Side effects: * None. @@ -4642,10 +4642,7 @@ int TclMSB( unsigned long long n) { - /* Bits in an unsigned long long */ - const int M = CHAR_BIT * sizeof(unsigned long long); - - if (M == 64) { + /* assert ( 64 == CHAR_BIT * sizeof(unsigned long long); */ /* * For a byte, consider two masks, C1 = 10000000 selecting just @@ -4654,20 +4651,20 @@ TclMSB( * LEAD(n) = C1 & (n | (C2 + (n & C2))) * will leave all bits but the high bit unset, and will have the * high bit set iff n!=0. The whole thing is an 8-bit test - * for being non-zero. For an 8-byte size_t, each byte can have + * for being non-zero. For an 8-byte n, each byte can have * the test applied all at once, with combined masks. */ - const size_t C1 = 0x8080808080808080; - const size_t C2 = 0x7F7F7F7F7F7F7F7F; + const unsigned long long C1 = 0x8080808080808080; + const unsigned long long C2 = 0x7F7F7F7F7F7F7F7F; #define LEAD(n) (C1 & (n | (C2 + (n & C2)))) /* * To shift a bit to a new place, multiplication by 2^k will do. * To shift the top 7 bits produced by the LEAD test to the high - * 7 bits of the entire size_t, multiply by the right sum of + * 7 bits of the entire long long, multiply by the right sum of * powers of 2. In this case * Q = 1 + 2^7 + 2^14 + 2^21 + 2^28 + 2^35 + 2^42 - * Then shift those 7 bits down to the low 7 bits of the size_t. + * Then shift those 7 bits down to the low 7 bits of the long long. * The key to making this work is that none of the shifted bits * collide with each other in the top 7-bit destination. * Note that we lose the bit that indicates whether the low byte @@ -4676,16 +4673,16 @@ TclMSB( * we know the low byte is non-zero, and if one of the other bytes * signals non-zero, we just don't care what the low byte is. */ - const size_t Q = 0x0000040810204081; + const unsigned long long Q = 0x0000040810204081; /* * To place a copy of a 7-bit value in each of 7 bytes in - * a size_t, just multply by the right value. In this case + * a long long, just multply by the right value. In this case * P = 0x00 01 01 01 01 01 01 01 * We don't put a copy in the high byte since analysis of the * remaining steps in the algorithm indicates we do not need it. */ - const size_t P = 0x0001010101010101; + const unsigned long long P = 0x0001010101010101; /* * With 7 copies of the LEAD value, we can now apply 7 masks @@ -4695,8 +4692,8 @@ TclMSB( * The higher the MSB of the copied value is, the more of the * B-masked bytes stored in t will be non-zero. */ - const size_t B = 0x007F7E7C78706040; - size_t t = B & P * (LEAD(n) * Q >> 57); + const unsigned long long B = 0x007F7E7C78706040; + unsigned long long t = B & P * (LEAD(n) * Q >> 57); /* * We want to get a count of the non-zero bytes stored in t. @@ -4709,7 +4706,7 @@ TclMSB( * P*X = x0*2^7 + (x0 + x1)*2^15 + ... * ... + (x0 + x1 + x2 + x3 + x4 + x5 + x6) * 2^55 + ... * ... + (x5 + x6)*2^95 + x6*2^103 - * The high terms of this product are going to overflow the size_t + * The high terms of this product are going to overflow the long long * and get lost, but we don't care about them. What we care is that * the 2^55 term is exactly the sum we seek. We shift the product * down by 55 bits and then mask away all but the bottom 3 bits @@ -4753,42 +4750,7 @@ TclMSB( */ #undef SUM - } else if (M == 32) { - - /* Same scheme as above, with adjustments to the 32-bit size */ - const size_t C1 = 0xA0820820; - const size_t C2 = 0x5F7DF7DF; - const size_t C3 = 0xC0820820; - const size_t C4 = 0x20000000; - const size_t Q = 0x00010841; - const size_t P = 0x01041041; - const size_t B = 0x1F79C610; - -#define SUM(t) (0x7 & (LEAD(t) * P >> 29)); - - size_t t = B & P * ((C3 & (LEAD(n) + C4)) * Q >> 27); - int k = 6 * SUM(t); - - t = B & P * (n >> k >> 1); - return k + SUM(t); - - /* Total operations: 33 - * 11 bit-ands, 6 multiplies, 5 adds, 5 rightshifts, - * 3 assignments, 3 bit-ors. - */ - -#undef SUM #undef LEAD - - } else { - /* Simple and slow fallback for cases we haven't done yet. */ - int k = 0; - - while (n >>= 1) { - k++; - } - return k; - } } /* -- cgit v0.12 From 6bdfb292f296ac40d0e07dca293a522b3a14c92b Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 23 Apr 2025 08:50:08 +0000 Subject: Starting to develop a new jump table type for numeric keys --- generic/tclCompCmdsSZ.c | 109 ++++++++++++++++++++++++++++++++++++++++++++---- generic/tclCompile.c | 10 +++++ generic/tclCompile.h | 33 ++++++++++++++- generic/tclExecute.c | 32 +++++++++++++- 4 files changed, 174 insertions(+), 10 deletions(-) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 80704c1..eb2f415 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -50,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); @@ -90,6 +93,14 @@ const AuxDataType tclJumptableInfoType = { PrintJumptableInfo, /* printProc */ DisassembleJumptableInfo /* disassembleProc */ }; + +const AuxDataType tclJumptableNumericInfoType = { + "JumptableNumInfo", /* name */ + DupJumptableNumInfo, /* dupProc */ + FreeJumptableInfo, /* freeProc */ + PrintJumptableNumInfo, /* printProc */ + DisassembleJumptableNumInfo /* disassembleProc */ +}; /* *---------------------------------------------------------------------- @@ -2341,8 +2352,7 @@ IssueSwitchJumpTable( * Start by allocating the jump table itself, plus some workspace. */ - jtPtr = (JumptableInfo *)Tcl_Alloc(sizeof(JumptableInfo)); - Tcl_InitHashTable(&jtPtr->hashTable, TCL_STRING_KEYS); + jtPtr = AllocJumptable(); infoIndex = TclCreateAuxData(jtPtr, &tclJumptableInfoType, envPtr); finalFixups = (Tcl_BytecodeLabel *)TclStackAlloc(interp, sizeof(Tcl_BytecodeLabel) * numArms); @@ -2385,6 +2395,10 @@ IssueSwitchJumpTable( Tcl_DStringInit(&buffer); TclDStringAppendToken(&buffer, arm->valueToken); if (noCase) { + /* + * We do case-insensitive matching by conversion to lower case. + */ + Tcl_Size slength = Tcl_UtfToLower(Tcl_DStringValue(&buffer)); Tcl_DStringSetLength(&buffer, slength); } @@ -2484,22 +2498,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 * *---------------------------------------------------------------------- */ @@ -2509,12 +2529,11 @@ 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, @@ -2586,6 +2605,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; + int isNew; + + hPtr = Tcl_FirstHashEntry(&jtnPtr->hashTable, &search); + for (; hPtr ; hPtr = Tcl_NextHashEntry(&search)) { + newHPtr = Tcl_CreateHashEntry(&newJtnPtr->hashTable, + Tcl_GetHashKey(&jtnPtr->hashTable, hPtr), &isNew); + 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)); + TclDictPut(NULL, mapping, Tcl_NewWideIntObj(key), + Tcl_NewWideIntObj(offset)); + } + TclDictPut(NULL, dictObj, "mapping", mapping); +} /* *---------------------------------------------------------------------- diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 058e857..db25285 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -477,6 +477,7 @@ InstructionDesc const tclInstructionTable[] = { /* 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. */ @@ -939,6 +940,15 @@ InstructionDesc const tclInstructionTable[] = { /* Modify the dict by replacing/creating the key/value pair given, * pushing the result on the stack. * Stack: ... dict key value => ... updatedDict */ + 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. */ {NULL, 0, 0, 0, {OPERAND_NONE}} }; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index ac38c02..593b878 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -878,7 +878,7 @@ enum TclInstruction { INST_CONST_IMM, INST_CONST_STK, - /* Updated compilations with fewer arg size constraints */ + /* Updated compilations with fewer arg size constraints for 9.1 */ INST_RETURN_CODE_BRANCH, INST_INCR_SCALAR, INST_INCR_ARRAY, @@ -888,10 +888,12 @@ enum TclInstruction { 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_JUMP_TABLE_NUM, /* The last opcode */ LAST_INST_OPCODE @@ -1074,7 +1076,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. */ @@ -1089,6 +1091,33 @@ MODULE_SCOPE const AuxDataType tclJumptableInfoType; #define JUMPTABLEINFO(envPtr, index) \ ((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; +} + +typedef struct JumptableNumInfo { + Tcl_HashTable hashTable; /* Hash that maps Tcl_WideInt to signed ints + * (PC offsets). */ +} JumptableNumInfo; + +MODULE_SCOPE const AuxDataType tclJumptableNumInfoType; + +#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; +} + /* * Structure used to hold information about a [dict update] command that is * needed during program execution. These structures are stored in CompileEnv diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 30cb717..13734e8 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -4484,7 +4484,7 @@ TEBCresume( /* * 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); @@ -4503,6 +4503,36 @@ TEBCresume( } } break; + case INST_JUMP_TABLE_NUM: { + Tcl_HashEntry *hPtr; + JumptableNumInfo *jtnPtr; + Tcl_WideInt key; + + /* + * Jump to location looked up in a hashtable; fall through to next + * instr if lookup fails. Lookup by integer. + */ + + opnd = TclGetInt4AtPtr(pc + 1); + jtnPtr = (JumptableNumInfo *) codePtr->auxDataArrayPtr[opnd].clientData; + TRACE(("%d \"%.20s\" => ", opnd, O2S(OBJ_AT_TOS))); + if (Tcl_GetWideIntFromObj(NULL, OBJ_AT_TOS, &key) != TCL_OK) { + goto jumpTableNumFallthrough; + } + hPtr = Tcl_FindHashEntry(&jtnPtr->hashTable, (void *)key); + if (hPtr != NULL) { + Tcl_Size jumpOffset = PTR2INT(Tcl_GetHashValue(hPtr)); + + TRACE_APPEND(("found in table, new pc %" TCL_Z_MODIFIER "u\n", + (pc - codePtr->codeStart + jumpOffset))); + NEXT_INST_F0(jumpOffset, 1); + } else { + jumpTableNumFallthrough: + TRACE_APPEND(("not found in table\n")); + NEXT_INST_F0(5, 1); + } + } + break; /* * ----------------------------------------------------------------- -- cgit v0.12 From a6bfdceed2b2c41119c5f950f811053046d7a867 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 23 Apr 2025 17:39:50 +0000 Subject: Speculative high performance implementation using Microsoft compiler intrinsics. UNTESTED!!! --- generic/tclUtil.c | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) diff --git a/generic/tclUtil.c b/generic/tclUtil.c index faabe07..aeae07d 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -19,6 +19,11 @@ #include "tclTomMath.h" #include +#if defined(_MSC_VER) && defined(_WIN64) +# include +# pragma intrinsic(_BitScanReverse64) +#endif + /* * The absolute pathname of the executable in which this Tcl library is * running. @@ -4644,6 +4649,24 @@ TclMSB( { /* assert ( 64 == CHAR_BIT * sizeof(unsigned long long); */ + /* + * Many platforms offer access to this functionality through + * compiler specific incantations that exploit processor + * instructions. Add more as appropriate. + */ + +#if defined(_MSC_VER) && defined(_WIN64) + /* + * This candidate implementation for Microsoft compilers is + * untested. (Remove this comment when someone tests it and + * either finds it working, or fixes any brokenness.) + */ + unsigned long result; + + (void) _BitScanReverse64(&result, (unsigned __int64)n); + return (int)result; +#else + /* * For a byte, consider two masks, C1 = 10000000 selecting just * the high bit, and C2 = 01111111 selecting all other bits. @@ -4751,6 +4774,7 @@ TclMSB( #undef SUM #undef LEAD +#endif } /* -- cgit v0.12 From 7393667c57ecaaa773939eeecd53b5353ede5737 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 23 Apr 2025 18:27:05 +0000 Subject: High performance implementation using GNU compiler builtin. --- generic/tclUtil.c | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) diff --git a/generic/tclUtil.c b/generic/tclUtil.c index aeae07d..ee8ac43 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -4647,7 +4647,8 @@ int TclMSB( unsigned long long n) { - /* assert ( 64 == CHAR_BIT * sizeof(unsigned long long); */ + /* assert ( 64 == CHAR_BIT * sizeof(unsigned long long) ); */ + /* assert ( n != 0 ); */ /* * Many platforms offer access to this functionality through @@ -4665,6 +4666,18 @@ TclMSB( (void) _BitScanReverse64(&result, (unsigned __int64)n); return (int)result; + +#elif defined(__GNUC__) && ((__GNUC__ > 3) || (__GNUC__ == 3 && __GNUC_MINOR__ >= 4)) + + /* + * The GNU Compiler Collection offers this builtin routine + * starting with version 3.4, released 2004. + * clzll() = Count of Leading Zeroes in a Long Long + * NOTE: we rely on input constraint (n != 0). + */ + + return 63 - __builtin_clzll(n); + #else /* -- cgit v0.12 From 03eff5665c0a1444f5363599254cafd0084387ea Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 24 Apr 2025 10:06:25 +0000 Subject: Unneeded (char *) typecast --- generic/tclPlatDecls.h | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclPlatDecls.h b/generic/tclPlatDecls.h index b8243d2..fb7f616 100644 --- a/generic/tclPlatDecls.h +++ b/generic/tclPlatDecls.h @@ -219,9 +219,9 @@ extern const TclPlatStubs *tclPlatStubsPtr; #undef Tcl_WinTCharToUtf #ifdef _WIN32 #define Tcl_WinUtfToTChar(string, len, dsPtr) (Tcl_DStringInit(dsPtr), \ - (TCHAR *)Tcl_UtfToChar16DString((string), (len), (dsPtr))) + (TCHAR *)Tcl_UtfToChar16DString((string), (len), (dsPtr))) #define Tcl_WinTCharToUtf(string, len, dsPtr) (Tcl_DStringInit(dsPtr), \ - (char *)Tcl_Char16ToUtfDString((const unsigned short *)(string), ((((len) + 2) >> 1) - 1), (dsPtr))) + Tcl_Char16ToUtfDString((const unsigned short *)(string), ((((len) + 2) >> 1) - 1), (dsPtr))) #endif #endif -- cgit v0.12 From fb904527432b7966d75e52d68e3a56c4193bf4c9 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 25 Apr 2025 13:52:40 +0000 Subject: More towards the new jump table opcode --- generic/tclAssembly.c | 416 +++++++++++++++++++++++++++++++++++------------- generic/tclCompCmds.c | 2 + generic/tclCompCmdsSZ.c | 18 +-- generic/tclCompile.h | 51 +++++- generic/tclOptimize.c | 6 + 5 files changed, 366 insertions(+), 127 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index ba00892..a2e6b65 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -101,6 +101,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; @@ -264,10 +266,13 @@ static ByteCode * CompileAssembleObj(Tcl_Interp *interp, 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); + 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*); @@ -393,6 +398,7 @@ static const TalInstDesc TalInstructionTable[] = { // For legacy code {"jumpFalse4", ASSEM_JUMP, INST_JUMP_FALSE, 1, 0}, {"jumpTable", ASSEM_JUMPTABLE,INST_JUMP_TABLE, 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}, @@ -1169,9 +1175,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); } @@ -1224,7 +1231,6 @@ AssembleOneLine( int litIndex; /* Literal pool index of a constant */ Tcl_Size localVar; /* LVT index of a local variable */ int flags; /* Flags for a basic block */ - JumptableInfo* jtPtr; /* Pointer to a jumptable */ Tcl_Size infoIndex; /* Index of the jumptable in auxdata */ int status = TCL_ERROR; /* Return value from this function */ @@ -1477,7 +1483,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; @@ -1485,25 +1494,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; + } + + if (TalInstructionTable[tblIdx].tclInstCode == INST_JUMP_TABLE) { + JumptableInfo* jtPtr = AllocJumptable(); + + 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 = RegisterJumptable(jtPtr, envPtr); + DEBUG_PRINT("auxdata index=%d\n", infoIndex); + + BBEmitInstInt4(assemEnvPtr, tblIdx, infoIndex, 0); + if (CreateMirrorJumpTable(assemEnvPtr, jtObjc, jtObjv) != TCL_OK) { + goto cleanup; + } + } else { + JumptableNumInfo* jtnPtr = AllocJumptableNum(); - jtPtr = (JumptableInfo*)Tcl_Alloc(sizeof(JumptableInfo)); - - Tcl_InitHashTable(&jtPtr->hashTable, TCL_STRING_KEYS); - 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)); + 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 = TclCreateAuxData(jtPtr, &tclJumptableInfoType, envPtr); - DEBUG_PRINT("auxdata index=%d\n", infoIndex); + infoIndex = RegisterJumptableNum(jtnPtr, 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 (CreateMirrorNumJumpTable(assemEnvPtr, jtObjc, jtObjv) != TCL_OK) { + goto cleanup; + } } StartBasicBlock(assemEnvPtr, BB_JUMPTABLE|BB_FALLTHRU, NULL); break; + } case ASSEM_LABEL: if (parsePtr->numWords != 2) { @@ -1855,8 +1893,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)); @@ -1887,10 +1925,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; @@ -1898,35 +1935,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. @@ -1936,19 +2032,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, (void*)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"); @@ -1957,8 +2060,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; } /* @@ -1973,23 +2080,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); } /* @@ -2588,6 +2710,7 @@ AllocBB( bb->foreignExceptionCount = 0; bb->foreignExceptions = NULL; bb->jtPtr = NULL; + bb->jtnPtr = NULL; bb->flags = 0; return bb; @@ -2746,8 +2869,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 */ @@ -2758,18 +2880,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"); @@ -2874,15 +3015,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; @@ -2892,38 +3029,90 @@ ResolveJumpTableTargets( /* 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; - 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("}\n"); + /* + * 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("}\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), &junk); + 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"); + } } /* @@ -3300,8 +3489,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); @@ -3622,7 +3812,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); diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 973dac8..6d5c35b 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -101,6 +101,8 @@ TclGetAuxDataType( return &dictUpdateInfoType; } else if (!strcmp(typeName, tclJumptableInfoType.name)) { return &tclJumptableInfoType; + } else if (!strcmp(typeName, tclJumptableNumericInfoType.name)) { + return &tclJumptableNumericInfoType; } return NULL; } diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index eb2f415..c1083c6 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -2332,7 +2332,6 @@ IssueSwitchJumpTable( 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 @@ -2353,7 +2352,7 @@ IssueSwitchJumpTable( */ jtPtr = AllocJumptable(); - infoIndex = TclCreateAuxData(jtPtr, &tclJumptableInfoType, envPtr); + infoIndex = RegisterJumptable(jtPtr, envPtr); finalFixups = (Tcl_BytecodeLabel *)TclStackAlloc(interp, sizeof(Tcl_BytecodeLabel) * numArms); foundDefault = 0; @@ -2402,16 +2401,8 @@ IssueSwitchJumpTable( Tcl_Size slength = Tcl_UtfToLower(Tcl_DStringValue(&buffer)); Tcl_DStringSetLength(&buffer, slength); } - hPtr = Tcl_CreateHashEntry(&jtPtr->hashTable, - Tcl_DStringValue(&buffer), &isNew); - if (isNew) { - /* - * First time we've encountered this match clause, so it must - * point to here. - */ - - Tcl_SetHashValue(hPtr, INT2PTR(CurrentOffset(envPtr) - jumpLocation)); - } + CreateJumptableEntry(jtPtr, Tcl_DStringValue(&buffer), + CurrentOffset(envPtr) - jumpLocation); Tcl_DStringFree(&buffer); } else { /* @@ -2676,7 +2667,8 @@ DisassembleJumptableNumInfo( for (; hPtr ; hPtr = Tcl_NextHashEntry(&search)) { key = (Tcl_Size) Tcl_GetHashKey(&jtnPtr->hashTable, hPtr); offset = PTR2INT(Tcl_GetHashValue(hPtr)); - TclDictPut(NULL, mapping, Tcl_NewWideIntObj(key), + // Cannot fail: keys already known to be unique + Tcl_DictObjPut(NULL, mapping, Tcl_NewWideIntObj(key), Tcl_NewWideIntObj(offset)); } TclDictPut(NULL, dictObj, "mapping", mapping); diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 593b878..dea6a1f 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -385,7 +385,7 @@ typedef struct CompileEnv { /* TIP #280 */ ExtCmdLoc *extCmdMapPtr; /* Extended command location information for * 'info frame'. */ - int 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 @@ -1099,12 +1099,25 @@ AllocJumptable(void) return jtPtr; } +static inline void +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)); + } +} + typedef struct JumptableNumInfo { Tcl_HashTable hashTable; /* Hash that maps Tcl_WideInt to signed ints * (PC offsets). */ } JumptableNumInfo; -MODULE_SCOPE const AuxDataType tclJumptableNumInfoType; +MODULE_SCOPE const AuxDataType tclJumptableNumericInfoType; #define JUMPTABLENUMINFO(envPtr, index) \ ((JumptableNumInfo *) TclFetchAuxData((envPtr), TclGetUInt4AtPtr(index))) @@ -1118,6 +1131,20 @@ AllocJumptableNum(void) return jtnPtr; } +static inline void +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)); + } +} + /* * Structure used to hold information about a [dict update] command that is * needed during program execution. These structures are stored in CompileEnv @@ -1940,6 +1967,26 @@ enum Lreplace4Flags { }; /* + * 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); +} + +/* * DTrace probe macros (NOPs if DTrace support is not enabled). */ diff --git a/generic/tclOptimize.c b/generic/tclOptimize.c index 9e6aa4a..5993fe2 100644 --- a/generic/tclOptimize.c +++ b/generic/tclOptimize.c @@ -99,10 +99,16 @@ LocateTargetAddresses( 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)); -- cgit v0.12 From 3bb36458a151be559871d34b7334ea1a1372fac6 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 25 Apr 2025 14:37:55 +0000 Subject: Add INST_DICT_REMOVE to go with INST_DICT_PUT --- generic/tclAssembly.c | 1 + generic/tclCompCmds.c | 37 ++++++++++++++++++++++++++++++++++++- generic/tclCompile.c | 8 ++++++-- generic/tclCompile.h | 1 + generic/tclDictObj.c | 2 +- generic/tclExecute.c | 19 +++++++++++++++++++ generic/tclInt.h | 1 + 7 files changed, 65 insertions(+), 4 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index ba00892..321d530 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -357,6 +357,7 @@ static const TalInstDesc TalInstructionTable[] = { {"dictPut", ASSEM_1BYTE, INST_DICT_PUT, 3, 1}, {"dictRecombineStk",ASSEM_1BYTE, INST_DICT_RECOMBINE_STK,3, 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}, diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 973dac8..fd08a97 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -1302,7 +1302,7 @@ TclCompileDictReplaceCmd( // Push starting dictionary tokenPtr = TokenAfter(parsePtr->tokenPtr); - PUSH_TOKEN( tokenPtr, 1); + PUSH_TOKEN( tokenPtr, 1); // Push the keys and values, and add them to the dictionary for (i=2; inumWords; + Tcl_Token *tokenPtr; + /* TODO: Consider support for compiling expanded args. */ + + /* + * Don't compile [dict remove $dict]; it's an edge case. + */ + if (numWords <= 3 || 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 ... 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 */ {NULL, 0, 0, 0, {OPERAND_NONE}} }; @@ -950,8 +955,7 @@ 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, diff --git a/generic/tclCompile.h b/generic/tclCompile.h index ac38c02..1be5fb6 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -892,6 +892,7 @@ enum TclInstruction { INST_ERROR_PREFIX_EQ, INST_TCLOO_ID, INST_DICT_PUT, + INST_DICT_REMOVE, /* The last opcode */ LAST_INST_OPCODE diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 39c0cc3..0d0a9e2 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -82,7 +82,7 @@ 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 }, + {"remove", DictRemoveCmd, TclCompileDictRemoveCmd, NULL, NULL, 0 }, {"replace", DictReplaceCmd, TclCompileDictReplaceCmd, NULL, NULL, 0 }, {"set", DictSetCmd, TclCompileDictSetCmd, NULL, NULL, 0 }, {"size", DictSizeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0 }, diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 30cb717..6825e25 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -7107,6 +7107,25 @@ TEBCresume( } 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) { + TRACE_ERROR(interp); + goto gotError; + } + TRACE_APPEND(("\"%.30s\"\n", O2S(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)); diff --git a/generic/tclInt.h b/generic/tclInt.h index a482229..89ea1ba 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3819,6 +3819,7 @@ 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; -- cgit v0.12 From 369748c4042514d48d5c8b544dc04edea3571405 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 25 Apr 2025 15:08:09 +0000 Subject: Fix cut-n-paste-ism --- generic/tclCompCmds.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index fd08a97..8983ed1 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -1334,7 +1334,7 @@ TclCompileDictRemoveCmd( /* * Don't compile [dict remove $dict]; it's an edge case. */ - if (numWords <= 3 || numWords > UINT_MAX) { + if (numWords <= 2 || numWords > UINT_MAX) { return TCL_ERROR; } -- cgit v0.12 From baee7785fdaafe98e4ebf512fb8292f7e7405e71 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 26 Apr 2025 15:08:29 +0000 Subject: Whether a value is new to a jump table matters. --- generic/tclCompCmdsSZ.c | 2 +- generic/tclCompile.h | 6 ++++-- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index c1083c6..76080c1 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -2401,7 +2401,7 @@ IssueSwitchJumpTable( Tcl_Size slength = Tcl_UtfToLower(Tcl_DStringValue(&buffer)); Tcl_DStringSetLength(&buffer, slength); } - CreateJumptableEntry(jtPtr, Tcl_DStringValue(&buffer), + isNew = CreateJumptableEntry(jtPtr, Tcl_DStringValue(&buffer), CurrentOffset(envPtr) - jumpLocation); Tcl_DStringFree(&buffer); } else { diff --git a/generic/tclCompile.h b/generic/tclCompile.h index d38c436..923ae3d 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -1100,7 +1100,7 @@ AllocJumptable(void) return jtPtr; } -static inline void +static inline int CreateJumptableEntry( JumptableInfo *jtPtr, const char *keyPtr, @@ -1111,6 +1111,7 @@ CreateJumptableEntry( if (isNew) { Tcl_SetHashValue(hPtr, INT2PTR(offset)); } + return isNew; } typedef struct JumptableNumInfo { @@ -1132,7 +1133,7 @@ AllocJumptableNum(void) return jtnPtr; } -static inline void +static inline int CreateJumptableNumEntry( JumptableNumInfo *jtnPtr, Tcl_Size key, @@ -1144,6 +1145,7 @@ CreateJumptableNumEntry( if (isNew) { Tcl_SetHashValue(hPtr, INT2PTR(offset)); } + return isNew; } /* -- cgit v0.12 From 03d79b534e50677bef1e00b7b90f0a41acdf0b6f Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 26 Apr 2025 15:52:49 +0000 Subject: Convert [subst] to use a numeric jump table instead of magic offset computations --- generic/tclCompCmdsSZ.c | 56 ++++++++++++++++++------------------------------- generic/tclCompile.c | 5 ----- generic/tclCompile.h | 10 +++++++-- generic/tclExecute.c | 20 ++---------------- generic/tclOptimize.c | 7 +------ 5 files changed, 31 insertions(+), 67 deletions(-) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 76080c1..533880f 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -1514,8 +1514,9 @@ TclSubstCompile( Tcl_Size length; int literal; Tcl_ExceptionRange catchRange; - Tcl_BytecodeLabel end, haveOk, haveReturn, haveBreak, haveContinue; - Tcl_BytecodeLabel haveOther; + Tcl_BytecodeLabel end, haveOk, haveOther, tableBase; + JumptableNumInfo *retCodeTable; + Tcl_AuxDataRef tableIdx; char buf[4] = ""; switch (tokenPtr->type) { @@ -1613,58 +1614,41 @@ TclSubstCompile( /* Exceptional return codes processed here */ CATCH_TARGET( catchRange); - OP( PUSH_RETURN_OPTIONS); - OP( PUSH_RESULT); OP( PUSH_RETURN_CODE); - OP( END_CATCH); - OP( RETURN_CODE_BRANCH); + + retCodeTable = AllocJumptableNum(); + tableIdx = RegisterJumptableNum(retCodeTable, envPtr); + tableBase = CurrentOffset(envPtr); + OP4( JUMP_TABLE_NUM, tableIdx); + FWDJUMP( JUMP, haveOther); /* 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); - OP( NOP); - OP( NOP); - OP( NOP); - OP( NOP); - - /* RETURN */ - FWDJUMP( JUMP, haveReturn); - - /* BREAK */ - FWDJUMP( JUMP, haveBreak); - - /* CONTINUE */ - FWDJUMP( JUMP, haveContinue); - - /* OTHER */ - FWDJUMP( JUMP, haveOther); + STKDELTA(-1); - STKDELTA(+1); /* BREAK destination */ - FWDLABEL( haveBreak); - OP( POP); - OP( POP); - + CreateJumptableNumEntryToHere(retCodeTable, TCL_BREAK, tableBase); + OP( END_CATCH); // catchRange BACKJUMP( JUMP, breakOffset); - STKDELTA(+2); /* CONTINUE destination */ - FWDLABEL( haveContinue); - OP( POP); - OP( POP); + CreateJumptableNumEntryToHere(retCodeTable, TCL_CONTINUE, tableBase); + OP( END_CATCH); // catchRange FWDJUMP( JUMP, end); - STKDELTA(+2); /* RETURN + other destination */ - FWDLABEL( haveReturn); FWDLABEL( haveOther); + OP( PUSH_RESULT); + OP( END_CATCH); // catchRange /* * Pull the result to top of stack, discard options dict. */ - OP( SWAP); - OP( POP); - /* OK destination */ FWDLABEL( haveOk); if (count > 1) { diff --git a/generic/tclCompile.c b/generic/tclCompile.c index fca3c1d..3ffe52d 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -881,11 +881,6 @@ InstructionDesc const tclInstructionTable[] = { /* Create constant. Variable name and value on stack. * Stack: ... varName value => ... */ - TCL_INSTRUCTION_ENTRY( - "returnCodeBranch", -1), - /* Jump to next instruction based on the return code on top of stack - * ERROR: +1; RETURN: +6; BREAK: +11; CONTINUE: +16; - * Other non-OK: +21 */ TCL_INSTRUCTION_ENTRY1( "incrScalar", 5, 0, OPERAND_LVT4), /* Incr scalar at index op1 in frame; incr amount is stktop */ diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 923ae3d..17ff30b 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -777,7 +777,7 @@ enum TclInstruction { /* For [subst] compilation */ INST_NOP, - DEPRECATED_OPCODE(INST_RETURN_CODE_BRANCH1), + DEPRECATED_OPCODE(INST_RETURN_CODE_BRANCH), /* For [unset] compilation */ INST_UNSET_SCALAR, @@ -879,7 +879,6 @@ enum TclInstruction { INST_CONST_STK, /* Updated compilations with fewer arg size constraints for 9.1 */ - INST_RETURN_CODE_BRANCH, INST_INCR_SCALAR, INST_INCR_ARRAY, INST_INCR_SCALAR_IMM, @@ -1114,6 +1113,9 @@ CreateJumptableEntry( 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). */ @@ -1148,6 +1150,10 @@ CreateJumptableNumEntry( 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 * needed during program execution. These structures are stored in CompileEnv diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 9638e27..a54ce07 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -6982,10 +6982,10 @@ TEBCresume( break; #ifndef REMOVE_DEPRECATED_OPCODES - case INST_RETURN_CODE_BRANCH1: { + case INST_RETURN_CODE_BRANCH: { int code; - DEPRECATED_OPCODE_MARK(INST_RETURN_CODE_BRANCH1); + 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!"); } @@ -7000,22 +7000,6 @@ TEBCresume( } #endif - case INST_RETURN_CODE_BRANCH: { - int code; - - if (TclGetIntFromObj(NULL, OBJ_AT_TOS, &code) != TCL_OK) { - Tcl_Panic("INST_RETURN_CODE_BRANCH: TOS not a return code!"); - } - if (code == TCL_OK) { - Tcl_Panic("INST_RETURN_CODE_BRANCH: TOS is TCL_OK!"); - } - if (code < TCL_ERROR || code > TCL_CONTINUE) { - code = TCL_CONTINUE + 1; - } - TRACE(("\"%s\" => jump offset %d\n", O2S(OBJ_AT_TOS), 5*code - 4)); - NEXT_INST_F0(5*code - 4, 1); - } - case INST_ERROR_PREFIX_EQ: { /* * A special equality operator for errorcode prefix matching in diff --git a/generic/tclOptimize.c b/generic/tclOptimize.c index 5993fe2..c7ab998 100644 --- a/generic/tclOptimize.c +++ b/generic/tclOptimize.c @@ -116,17 +116,12 @@ LocateTargetAddresses( } break; #ifndef REMOVE_DEPRECATED_OPCODES - case INST_RETURN_CODE_BRANCH1: + case INST_RETURN_CODE_BRANCH: for (i=TCL_ERROR ; i Date: Sun, 27 Apr 2025 10:29:26 +0000 Subject: Crash tests for bugs [45b2] and [7d31] --- tests/lseq.test | 27 +++++++++++++++++++++++++++ 1 file changed, 27 insertions(+) diff --git a/tests/lseq.test b/tests/lseq.test index ceadac4..129c3c3 100644 --- a/tests/lseq.test +++ b/tests/lseq.test @@ -1065,6 +1065,33 @@ test lseq-bug-f4a4bd7f1070-1 {} -body { set result } -result {1 {expected integer but got "3.1"} 0 {5 6 7} {0 1 2} {0 1 2} {0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50} 0} +test lseq-bug-7d3101bf28-0 {Bug 7d3101bf28 - crash on negative index} -body { + list \ + [try [list lindex [lseq 10] -1]] \ + [eval [list lindex [lseq 10] -1]] +} -result {{} {}} -constraints bug_7d3101bf28 + +test lseq-bug-7d3101bf28-1 {Bug 7d3101bf28 - crash on out of bounds index} -body { + list \ + [try [list lindex [lseq 10] 10]] \ + [eval [list lindex [lseq 10] 10]] +} -result {{} {}} -constraints bug_7d3101bf28 + +test lseq-bug-7d3101bf28-2 {Bug 7d3101bf28 - crash on error in index syntax} -body { + list \ + [try [list lindex [lseq 10] foo]] \ + [eval [list lindex [lseq 10] foo]] +} -result {{} {}} -constraints bug_7d3101bf28 + +test lseq-bug-452b103a74-1 {Bug 452b103a74 - crash on nested indices} -body { + lindex [lseq 10] 0 1 +} -result {} -constraints bug_452b103a74 + +test lseq-bug-452b103a74-2 {Bug 452b103a74 - crash on nested indices} -body { + lindex [lseq 10] 0 end +} -result {} -constraints bug_452b103a74 + + # cleanup ::tcltest::cleanupTests -- cgit v0.12 From 81f7db2d515282dbe2a1bf9b0908a160b2b2f0ec Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sun, 27 Apr 2025 10:42:36 +0000 Subject: Fix lindex crash on non-numeric index into lseq --- generic/tclListObj.c | 5 +++-- tests/lseq.test | 2 +- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 36914bc..38a2fd6 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -2670,8 +2670,8 @@ TclLindexFlat( Tcl_Obj *elemObj = listObj; /* for lindex without indices return list */ for (i=0 ; i Date: Sun, 27 Apr 2025 10:48:52 +0000 Subject: Fix [7d3101bf28] - crash on out of bounds lindex into lseq --- generic/tclListObj.c | 7 +++++++ tests/lseq.test | 4 ++-- 2 files changed, 9 insertions(+), 2 deletions(-) diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 38a2fd6..077da68 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -2684,6 +2684,13 @@ TclLindexFlat( elemObj = e2Obj; } } + if (elemObj == NULL) { + /* + * TclObjTypeIndex returns TCL_OK with NULL in elemObj if + * index was out of bounds. + */ + TclNewObj(elemObj); + } Tcl_IncrRefCount(elemObj); return elemObj; } diff --git a/tests/lseq.test b/tests/lseq.test index 9d7ebca..d0871fb 100644 --- a/tests/lseq.test +++ b/tests/lseq.test @@ -1069,13 +1069,13 @@ test lseq-bug-7d3101bf28-0 {Bug 7d3101bf28 - crash on negative index} -body { list \ [try [list lindex [lseq 10] -1]] \ [eval [list lindex [lseq 10] -1]] -} -result {{} {}} -constraints bug_7d3101bf28 +} -result {{} {}} test lseq-bug-7d3101bf28-1 {Bug 7d3101bf28 - crash on out of bounds index} -body { list \ [try [list lindex [lseq 10] 10]] \ [eval [list lindex [lseq 10] 10]] -} -result {{} {}} -constraints bug_7d3101bf28 +} -result {{} {}} test lseq-bug-7d3101bf28-2 {Bug 7d3101bf28 - crash on error in index syntax} -body { list \ -- cgit v0.12 From 7e6ae2d3b4697ddb1e88e268e94afeed8daaa9b4 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sun, 27 Apr 2025 14:59:58 +0000 Subject: Partial fix and test cases for bug [452b103a74] - lseq nested indices --- generic/tclListObj.c | 2 +- tests/lseq.test | 23 +++++++++++++++++++---- 2 files changed, 20 insertions(+), 5 deletions(-) diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 077da68..d11fac9 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -2664,7 +2664,7 @@ TclLindexFlat( Tcl_Size i; /* Handle AbstractList as special case */ - if (TclObjTypeHasProc(listObj,indexProc)) { + if (indexCount == 1 && TclObjTypeHasProc(listObj,indexProc)) { Tcl_Size listLen = TclObjTypeLength(listObj); Tcl_Size index; Tcl_Obj *elemObj = listObj; /* for lindex without indices return list */ diff --git a/tests/lseq.test b/tests/lseq.test index d0871fb..168abc8 100644 --- a/tests/lseq.test +++ b/tests/lseq.test @@ -1083,14 +1083,29 @@ test lseq-bug-7d3101bf28-2 {Bug 7d3101bf28 - crash on error in index syntax} -bo [eval [list lindex [lseq 10] foo]] } -result {bad index "foo": must be integer?[+-]integer? or end?[+-]integer?} -returnCodes error -test lseq-bug-452b103a74-1 {Bug 452b103a74 - crash on nested indices} -body { +test lseq-bug-452b103a74-0 {Bug 452b103a74 - crash on nested indices} -body { lindex [lseq 10] 0 1 -} -result {} -constraints bug_452b103a74 +} -result {} -test lseq-bug-452b103a74-2 {Bug 452b103a74 - crash on nested indices} -body { +test lseq-bug-452b103a74-1 {Bug 452b103a74 - crash on nested indices} -body { lindex [lseq 10] 0 end -} -result {} -constraints bug_452b103a74 +} -result 0 + +test lseq-bug-452b103a74-2 {Bug 452b103a74 - crash on nested indices} -body { + lindex [lseq 10] {0 1} +} -result {} + +test lseq-bug-452b103a74-3 {Bug 452b103a74 - crash on nested indices} -body { + lindex [lseq 10] {0 end} +} -result 0 + +test lseq-bug-452b103a74-4 {Bug 452b103a74 - crash on nested indices} -body { + lindex [lseq 10] 1 0 +} -result 1 +test lseq-bug-452b103a74-5 {Bug 452b103a74 - crash on nested indices} -body { + lindex [lseq 10] {end 0} +} -result 9 # cleanup ::tcltest::cleanupTests -- cgit v0.12 From 6625300b0d9ae0a8ee16b878f77a559560b533d5 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Mon, 28 Apr 2025 03:05:52 +0000 Subject: Fix compiled indexlist for lseq --- generic/tclExecute.c | 36 ++++++++++++++++-------------------- 1 file changed, 16 insertions(+), 20 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index ad09f47..ecd7a8b 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -4717,28 +4717,24 @@ TEBCresume( length = TclObjTypeLength(valuePtr); if (TclGetIntForIndexM(interp, value2Ptr, length-1, &index)!=TCL_OK) { CACHE_STACK_INFO(); - TRACE_ERROR(interp); - goto gotError; - } - if (TclObjTypeIndex(interp, valuePtr, index, &objResultPtr)!=TCL_OK) { + /* Could be list of indices. Let TclLindexList handle it below */ + } else { + if (TclObjTypeIndex(interp, valuePtr, index, &objResultPtr) != + TCL_OK) { + CACHE_STACK_INFO(); + TRACE_ERROR(interp); + goto gotError; + } CACHE_STACK_INFO(); - TRACE_ERROR(interp); - goto gotError; - } - CACHE_STACK_INFO(); - if (objResultPtr == NULL) { - /* Index is out of range, return empty result. */ - TclNewObj(objResultPtr); + if (objResultPtr == NULL) { + /* Index is out of range, return empty result. */ + TclNewObj(objResultPtr); + } + Tcl_IncrRefCount(objResultPtr); // reference held here + goto lindexDone; } - Tcl_IncrRefCount(objResultPtr); // reference held here - goto lindexDone; - } - - /* - * Extract the desired list element. - */ - - { + } else { + /* Non-abstract list */ Tcl_Size value2Length; Tcl_Obj *indexListPtr = value2Ptr; -- cgit v0.12 From 8e247cc6a3b3360c6f0b2d26f722529376e6d5af Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 28 Apr 2025 07:37:06 +0000 Subject: Attempt to fix cmdAH test failures. Doesn't work. --- win/tclWinTest.c | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/win/tclWinTest.c b/win/tclWinTest.c index 72e1e83..01a02a5 100644 --- a/win/tclWinTest.c +++ b/win/tclWinTest.c @@ -43,7 +43,7 @@ static Tcl_ObjCmdProc TestvolumetypeCmd; static Tcl_ObjCmdProc TestwinclockCmd; static Tcl_ObjCmdProc TestwinsleepCmd; static Tcl_ObjCmdProc TestExceptionCmd; -static int TestplatformChmod(const char *nativePath, int pmode); +static int TestplatformChmod(const char *nativePath, int pmode, Tcl_Encoding encoding); static Tcl_ObjCmdProc TestchmodCmd; /* @@ -398,7 +398,8 @@ TestExceptionCmd( static int TestplatformChmod( const char *nativePath, - int pmode) + int pmode, + Tcl_Encoding encoding) { /* * Note FILE_DELETE_CHILD missing from dirWriteMask because we do @@ -444,7 +445,7 @@ TestplatformChmod( res = -1; /* Assume failure */ Tcl_DStringInit(&ds); - Tcl_UtfToExternalDString(NULL, nativePath, -1, &ds); + Tcl_UtfToExternalDString(encoding, nativePath, -1, &ds); attr = GetFileAttributesA(Tcl_DStringValue(&ds)); if (attr == 0xFFFFFFFF) { @@ -641,6 +642,7 @@ TestchmodCmd( Tcl_Obj *const * objv) /* Parameter vector */ { int i, mode; + Tcl_DString ds; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "mode file ?file ...?"); @@ -651,6 +653,9 @@ TestchmodCmd( return TCL_ERROR; } + Tcl_Encoding encoding = Tcl_GetEncoding(interp, Tcl_GetEncodingNameForUser(&ds)); + Tcl_DStringFree(&ds); + for (i = 2; i < objc; i++) { Tcl_DString buffer; const char *translated; @@ -659,7 +664,7 @@ TestchmodCmd( if (translated == NULL) { return TCL_ERROR; } - if (TestplatformChmod(translated, mode) != 0) { + if (TestplatformChmod(translated, mode, encoding) != 0) { Tcl_AppendResult(interp, translated, ": ", Tcl_PosixError(interp), (char *)NULL); return TCL_ERROR; -- cgit v0.12 From fa450103b8bb6e10d834e9ae7f2ee371b89ba352 Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 28 Apr 2025 09:03:29 +0000 Subject: Preparing to use a numeric jump table in [try]... but that's tricky to get right so it'll be in a later commit. --- generic/tclCompCmdsSZ.c | 42 +++++++++++++++++++++++++----------------- 1 file changed, 25 insertions(+), 17 deletions(-) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 533880f..f451eb1 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -2834,7 +2834,7 @@ TclCompileTryCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Size numHandlers, numWords = parsePtr->numWords; - int result = TCL_ERROR; + int result = TCL_ERROR, anyTrapClauses = 0; Tcl_Token *bodyToken, *finallyToken, *tokenPtr; TryHandlerInfo staticHandler, *handlers = &staticHandler; Tcl_Size handlerIdx = 0; @@ -2893,6 +2893,7 @@ TclCompileTryCmd( Tcl_ListObjReplace(NULL, tmpObj, 0, 0, 0, NULL); Tcl_IncrRefCount(tmpObj); handlers[handlerIdx].matchClause = tmpObj; + anyTrapClauses = 1; } else if (IS_TOKEN_LITERALLY(tokenPtr, "on")) { int code; @@ -3003,12 +3004,18 @@ TclCompileTryCmd( */ if (!finallyToken) { + if (!anyTrapClauses) { + // TODO: Use a JUMP_TABLE_NUM + } result = IssueTryClausesInstructions(interp, envPtr, bodyToken, numHandlers, handlers); } else if (numHandlers == 0) { result = IssueTryFinallyInstructions(interp, envPtr, bodyToken, finallyToken); } else { + if (!anyTrapClauses) { + // TODO: Use a JUMP_TABLE_NUM + } result = IssueTryClausesFinallyInstructions(interp, envPtr, bodyToken, numHandlers, handlers, finallyToken); } @@ -3040,8 +3047,6 @@ TclCompileTryCmd( * 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. - * *---------------------------------------------------------------------- */ @@ -3058,8 +3063,9 @@ IssueTryClausesInstructions( Tcl_Size i, j, len; int forwardsNeedFixing = 0, trapZero = 0; Tcl_ExceptionRange range; - Tcl_BytecodeLabel afterBody = 0, pushReturnOptions = 0, *forwardsToFix; - Tcl_BytecodeLabel notCodeJumpSource, notECJumpSource, *addrsToFix, *noError; + Tcl_BytecodeLabel afterBody = 0, pushReturnOptions = 0; + Tcl_BytecodeLabel notCodeJumpSource, notECJumpSource, dontChangeOptions; + Tcl_BytecodeLabel *forwardsToFix, *addrsToFix, *noError; resultVar = AnonymousLocal(envPtr); optionsVar = AnonymousLocal(envPtr); @@ -3160,19 +3166,17 @@ IssueTryClausesInstructions( OP4( LOAD_SCALAR, resultVar); OP4( STORE_SCALAR, handlers[i].resultVar); OP( POP); - if (handlers[i].optionVar >= 0) { - OP4( LOAD_SCALAR, optionsVar); - OP4( STORE_SCALAR, handlers[i].optionVar); - OP( POP); - } + } + if (handlers[i].optionVar >= 0) { + OP4( LOAD_SCALAR, optionsVar); + OP4( STORE_SCALAR, handlers[i].optionVar); + OP( POP); } if (!handlers[i].tokenPtr) { forwardsNeedFixing = 1; FWDJUMP( JUMP, forwardsToFix[i]); STKDELTA(+1); } else { - Tcl_BytecodeLabel dontChangeOptions; - forwardsToFix[i] = -1; if (forwardsNeedFixing) { forwardsNeedFixing = 0; @@ -3184,6 +3188,7 @@ IssueTryClausesInstructions( forwardsToFix[j] = -1; } } + range = MAKE_CATCH_RANGE(); OP4( BEGIN_CATCH, range); CATCH_RANGE(range) { @@ -3366,15 +3371,18 @@ IssueTryClausesFinallyInstructions( * failed trap for the result from the main script. */ - if (handlers[i].resultVar >= 0 || handlers[i].tokenPtr) { + if (handlers[i].resultVar >= 0 || handlers[i].optionVar >= 0 + || handlers[i].tokenPtr) { range = MAKE_CATCH_RANGE(); OP4( BEGIN_CATCH, range); ExceptionRangeStarts(envPtr, range); } - if (handlers[i].resultVar >= 0) { - OP4( LOAD_SCALAR, resultLocal); - OP4( STORE_SCALAR, handlers[i].resultVar); - OP( POP); + if (handlers[i].resultVar >= 0 || handlers[i].optionVar >= 0) { + if (handlers[i].resultVar >= 0) { + OP4( LOAD_SCALAR, resultLocal); + OP4( STORE_SCALAR, handlers[i].resultVar); + OP( POP); + } if (handlers[i].optionVar >= 0) { OP4( LOAD_SCALAR, optionsLocal); OP4( STORE_SCALAR, handlers[i].optionVar); -- cgit v0.12 From a905678adc56897b8ccdf22d6da740f08b18ad77 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Mon, 28 Apr 2025 09:51:38 +0000 Subject: Minor tweak. Pass interp as NULL as error thrown away. --- generic/tclExecute.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index ecd7a8b..c6adfd6 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -4715,7 +4715,7 @@ TEBCresume( if (TclObjTypeHasProc(valuePtr, indexProc)) { DECACHE_STACK_INFO(); length = TclObjTypeLength(valuePtr); - if (TclGetIntForIndexM(interp, value2Ptr, length-1, &index)!=TCL_OK) { + if (TclGetIntForIndexM(NULL, value2Ptr, length-1, &index)!=TCL_OK) { CACHE_STACK_INFO(); /* Could be list of indices. Let TclLindexList handle it below */ } else { -- cgit v0.12 From 745e9ef82ff791d68890c17ef4a97027de89dc29 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Mon, 28 Apr 2025 10:15:07 +0000 Subject: Start on test suite for all internal list representations --- generic/tclListTypes.c | 4 +- tests/listTypes.test | 183 +++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 185 insertions(+), 2 deletions(-) create mode 100644 tests/listTypes.test diff --git a/generic/tclListTypes.c b/generic/tclListTypes.c index 714086c..a2ba2f4 100644 --- a/generic/tclListTypes.c +++ b/generic/tclListTypes.c @@ -214,7 +214,7 @@ static Tcl_ObjTypeReverseProc LreverseTypeReverse; * modification. */ static const Tcl_ObjType lreverseType = { - "lreverse", /* name */ + "reversedList", /* name */ LreverseFreeIntrep, /* freeIntRepProc */ LreverseDupIntrep, /* dupIntRepProc */ TclAbstractListUpdateString, /* updateStringProc */ @@ -394,7 +394,7 @@ static Tcl_ObjTypeIndexProc LrepeatTypeIndex; * may be shared must be checked before modification. */ static const Tcl_ObjType lrepeatType = { - "lrepeat", /* name */ + "repeatedList", /* name */ LrepeatFreeIntrep, /* freeIntRepProc */ LrepeatDupIntrep, /* dupIntRepProc */ TclAbstractListUpdateString, /* updateStringProc */ diff --git a/tests/listTypes.test b/tests/listTypes.test new file mode 100644 index 0000000..db73635 --- /dev/null +++ b/tests/listTypes.test @@ -0,0 +1,183 @@ +# 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 +# +# All list operations, loops, {*} expansion need to be tested with each of the +# above types. The first three of these are already tested in cmdIL.test, +# lseq.test, listrep.test etc. but are included here for completeness. Note the +# tests here do not test command options to the commands as those are already +# tested in the aforementioned files. +# +# For the abstract list types not tested elsewhere, +# - verify constructor commands return the expected type +# - generated string representations + +# Test list operations include combinations of +# - Compiled / uncompiled operation +# - Shared / unshared operands +# - List internal representation types. +# +# TODO - see comments to testlistobj +# TODO - see listobjmemcheck and indexmemcheck in listObj.test +# TODO - lrepeat/lreverse string generation when starting with # +# TODO -lrepeat/lreverse list of braces +# TODO - nested lrepeat with index list and separate indices +# TODO - nested list combinations. Verify none of the lists shimmer +# TODO - [lreverse [lreverse]] should retrieve original list. + +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]] + +testConstraint testobj [llength [info commands testobj]] +testConstraint testlistobj [llength [info commands testobj]] + +namespace eval listtype { + variable listTypes {arithseries list repeatedList reversedList spanlist} + + # Loop vars etc. + variable ltype + variable first + variable last + + # 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 1000 + + + 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\"" + } + } + + # Returns a list of length $largeListLength of the specified type + proc makeList {type} { + variable largeListLength + set l [switch $type { + list { + testlistrep new $largeListLength + } + spanlist { + # Spanned list - force span by leaving 10 empty slots in front + testlistrep new $largeListLength 10 + } + arithseries { + lseq $largeListLength + } + repeatedList { + lrepeat [expr {$largeListLength/4}] a b c d + } + reversedList { + lreverse [makeList list] + } + }] + assertListType $l $type + return $l + } + + # Wrapper to generate compiled and uncompiled 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 + + 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] + + dict append args -setup \n[list proc testxproc {ltype} $body] + dict append args -cleanup "\nrename testxproc {}" + uplevel 1 [list test $id.compiled-proc "$comment (compiled proc)" \ + -body {testxproc $ltype} \ + {*}$args] + } + + # llength + foreach ltype $listTypes { + testdef llength-$ltype-0 "llength of type $ltype" -body { + set l [makeList $ltype] + list [getListType $l] [llength $l] + } -result [list $ltype $largeListLength] + } + + # lindex + foreach ltype $listTypes { + switch $ltype { + repeatedList { + set first a + set last d + } + reversedList { + set last 0 + set first [expr {$largeListLength-1}] + } + default { + set first 0 + set last [expr {$largeListLength-1}] + } + } + testdef lindex-$ltype-0 "lindex 0 of type $ltype" -body { + set l [makeList $ltype] + list [getListType $l] [lindex $l 0] + } -result [list $ltype $first] + + testdef lindex-$ltype-1 "lindex end of type $ltype" -body { + set l [makeList $ltype] + list [getListType $l] [lindex $l end] + } -result [list $ltype $last] + + testdef lindex-$ltype-2 "lindex -1 of type $ltype" -body { + set l [makeList $ltype] + list [getListType $l] [lindex $l -1] + } -result [list $ltype {}] + + testdef lindex-$ltype-2 "lindex -1 of type $ltype" -body { + set l [makeList $ltype] + list [getListType $l] [lindex $l [llength $l]] + } -result [list $ltype {}] + } + +} + +# All done +::tcltest::cleanupTests -- cgit v0.12 From 67681ec324afbb26bfed68799c99ffb0eef0c385 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Mon, 28 Apr 2025 11:30:02 +0000 Subject: Fix cmdAH tests. See comments below. Tcl_GetEncodingForUser will not be available until 9.1 for stubs compatibility. In any case, as a rule, wide char API's should be used in code and tests to avoid the exact kind of problems we are currently trying to solve with code pages. --- win/tclWinTest.c | 19 +++++++------------ 1 file changed, 7 insertions(+), 12 deletions(-) diff --git a/win/tclWinTest.c b/win/tclWinTest.c index 01a02a5..005fb37 100644 --- a/win/tclWinTest.c +++ b/win/tclWinTest.c @@ -43,7 +43,7 @@ static Tcl_ObjCmdProc TestvolumetypeCmd; static Tcl_ObjCmdProc TestwinclockCmd; static Tcl_ObjCmdProc TestwinsleepCmd; static Tcl_ObjCmdProc TestExceptionCmd; -static int TestplatformChmod(const char *nativePath, int pmode, Tcl_Encoding encoding); +static int TestplatformChmod(const char *nativePath, int pmode); static Tcl_ObjCmdProc TestchmodCmd; /* @@ -398,8 +398,7 @@ TestExceptionCmd( static int TestplatformChmod( const char *nativePath, - int pmode, - Tcl_Encoding encoding) + int pmode) { /* * Note FILE_DELETE_CHILD missing from dirWriteMask because we do @@ -445,9 +444,9 @@ TestplatformChmod( res = -1; /* Assume failure */ Tcl_DStringInit(&ds); - Tcl_UtfToExternalDString(encoding, nativePath, -1, &ds); + Tcl_UtfToChar16DString(nativePath, -1, &ds); - attr = GetFileAttributesA(Tcl_DStringValue(&ds)); + attr = GetFileAttributesW((WCHAR *)Tcl_DStringValue(&ds)); if (attr == 0xFFFFFFFF) { goto done; /* Not found */ } @@ -587,7 +586,7 @@ TestplatformChmod( * to remove inherited ACL (we need to overwrite the default ACL's in this case) */ - if (SetNamedSecurityInfoA((LPSTR)Tcl_DStringValue(&ds), SE_FILE_OBJECT, + if (SetNamedSecurityInfoW((LPWSTR)Tcl_DStringValue(&ds), SE_FILE_OBJECT, DACL_SECURITY_INFORMATION | PROTECTED_DACL_SECURITY_INFORMATION, NULL, NULL, newAcl, NULL) == ERROR_SUCCESS) { res = 0; @@ -609,7 +608,7 @@ TestplatformChmod( if (res == 0) { /* Run normal chmod command */ - res = _chmod(Tcl_DStringValue(&ds), pmode); + res = _wchmod((WCHAR*)Tcl_DStringValue(&ds), pmode); } Tcl_DStringFree(&ds); return res; @@ -642,7 +641,6 @@ TestchmodCmd( Tcl_Obj *const * objv) /* Parameter vector */ { int i, mode; - Tcl_DString ds; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "mode file ?file ...?"); @@ -653,9 +651,6 @@ TestchmodCmd( return TCL_ERROR; } - Tcl_Encoding encoding = Tcl_GetEncoding(interp, Tcl_GetEncodingNameForUser(&ds)); - Tcl_DStringFree(&ds); - for (i = 2; i < objc; i++) { Tcl_DString buffer; const char *translated; @@ -664,7 +659,7 @@ TestchmodCmd( if (translated == NULL) { return TCL_ERROR; } - if (TestplatformChmod(translated, mode, encoding) != 0) { + if (TestplatformChmod(translated, mode) != 0) { Tcl_AppendResult(interp, translated, ": ", Tcl_PosixError(interp), (char *)NULL); return TCL_ERROR; -- cgit v0.12 From 2146c122aa2b36055531d711db57f6ec5009739c Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 28 Apr 2025 21:22:02 +0000 Subject: Use a jump table for [try] without 'trap' or 'finally' --- generic/tclCompCmdsSZ.c | 357 +++++++++++++++++++++++++++++++++++++----------- 1 file changed, 276 insertions(+), 81 deletions(-) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index f451eb1..c70e4fb 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -74,6 +74,9 @@ static void IssueSwitchJumpTable(Tcl_Interp *interp, static int IssueTryClausesInstructions(Tcl_Interp *interp, CompileEnv *envPtr, Tcl_Token *bodyToken, 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, Tcl_Size numHandlers, TryHandlerInfo *handlers, @@ -2627,7 +2630,7 @@ PrintJumptableNumInfo( } } Tcl_AppendPrintfToObj(appendObj, - "\"%"TCL_SIZE_MODIFIER"d\"->pc %" TCL_Z_MODIFIER "u", + "%"TCL_SIZE_MODIFIER"d->pc %" TCL_Z_MODIFIER "u", key, pcOffset + offset); } } @@ -2844,17 +2847,6 @@ TclCompileTryCmd( } 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); @@ -2995,6 +2987,10 @@ TclCompileTryCmd( if (finallyToken->type != TCL_TOKEN_SIMPLE_WORD) { goto failedToCompile; } + // Special case: empty finally clause + if (finallyToken[1].size == 0) { + finallyToken = NULL; + } } else { goto failedToCompile; } @@ -3003,12 +2999,22 @@ TclCompileTryCmd( * Issue the bytecode. */ - if (!finallyToken) { + 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) { - // TODO: Use a JUMP_TABLE_NUM + result = IssueTryTraplessClausesInstructions(interp, envPtr, + bodyToken, numHandlers, handlers); + } else { + result = IssueTryClausesInstructions(interp, envPtr, bodyToken, + numHandlers, handlers); } - result = IssueTryClausesInstructions(interp, envPtr, bodyToken, - numHandlers, handlers); } else if (numHandlers == 0) { result = IssueTryFinallyInstructions(interp, envPtr, bodyToken, finallyToken); @@ -3061,11 +3067,11 @@ IssueTryClausesInstructions( DefineLineInformation; /* TIP #280 */ Tcl_LVTIndex resultVar, optionsVar; Tcl_Size i, j, len; - int forwardsNeedFixing = 0, trapZero = 0; + int continuationsPending = 0, trapZero = 0; Tcl_ExceptionRange range; Tcl_BytecodeLabel afterBody = 0, pushReturnOptions = 0; - Tcl_BytecodeLabel notCodeJumpSource, notECJumpSource, dontChangeOptions; - Tcl_BytecodeLabel *forwardsToFix, *addrsToFix, *noError; + Tcl_BytecodeLabel notCodeJumpSource, notECJumpSource, dontSpliceDuring; + Tcl_BytecodeLabel *continuationJumps, *afterReturn0, *noError; resultVar = AnonymousLocal(envPtr); optionsVar = AnonymousLocal(envPtr); @@ -3127,13 +3133,15 @@ IssueTryClausesInstructions( * Slight overallocation, but reduces size of this function. */ - addrsToFix = (Tcl_BytecodeLabel *)TclStackAlloc(interp, + afterReturn0 = (Tcl_BytecodeLabel *)TclStackAlloc(interp, sizeof(Tcl_BytecodeLabel) * numHandlers * 3); - forwardsToFix = addrsToFix + numHandlers; - noError = forwardsToFix + numHandlers; + continuationJumps = afterReturn0 + numHandlers; + noError = continuationJumps + numHandlers; + for (i=0; i 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= 0) { + OP4( LOAD_SCALAR, resultVar); + OP4( STORE_SCALAR, handlers[i].resultVar); + OP( POP); + } + if (handlers[i].optionVar >= 0) { + 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 Date: Tue, 29 Apr 2025 08:51:25 +0000 Subject: Unbreak (gcc) build --- win/tclWinInit.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/win/tclWinInit.c b/win/tclWinInit.c index 57bd63f..35ce207 100644 --- a/win/tclWinInit.c +++ b/win/tclWinInit.c @@ -115,7 +115,7 @@ static const OSVERSIONINFOW *TclpGetWindowsVersion(void) static INIT_ONCE osInfoOnce = INIT_ONCE_STATIC_INIT; OSVERSIONINFOW *osInfoPtr = NULL; BOOL result = InitOnceExecuteOnce( - &osInfoOnce, TclpGetWindowsVersionOnce, NULL, &osInfoPtr); + &osInfoOnce, TclpGetWindowsVersionOnce, NULL, (LPVOID *)&osInfoPtr); return result ? osInfoPtr : NULL; } @@ -475,7 +475,7 @@ const char * Tcl_GetEncodingNameFromEnvironment( Tcl_DString *bufPtr) { - OSVERSIONINFOW *osInfoPtr = TclpGetWindowsVersion(); + const OSVERSIONINFOW *osInfoPtr = TclpGetWindowsVersion(); /* * TIP 716 - for Build 18362 or higher, force utf-8. Note Windows build * numbers always increase, so no need to check major / minor versions. -- cgit v0.12 From 93069ee44f5962ef803b537691b3330e104506fd Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 29 Apr 2025 09:20:14 +0000 Subject: Convert [try ... on ... finally ...] to use a jump table --- generic/tclCompCmdsSZ.c | 295 ++++++++++++++++++++++++++++++++++++++++++++++-- tests/error.test | 72 ++++++++++++ 2 files changed, 359 insertions(+), 8 deletions(-) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index c70e4fb..ceebd44 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -81,6 +81,11 @@ static int IssueTryClausesFinallyInstructions(Tcl_Interp *interp, CompileEnv *envPtr, Tcl_Token *bodyToken, 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, Tcl_Token *finallyToken); @@ -2630,7 +2635,7 @@ PrintJumptableNumInfo( } } Tcl_AppendPrintfToObj(appendObj, - "%"TCL_SIZE_MODIFIER"d->pc %" TCL_Z_MODIFIER "u", + "%" TCL_SIZE_MODIFIER "d->pc %" TCL_Z_MODIFIER "u", key, pcOffset + offset); } } @@ -3020,10 +3025,12 @@ TclCompileTryCmd( finallyToken); } else { if (!anyTrapClauses) { - // TODO: Use a JUMP_TABLE_NUM + result = IssueTryTraplessClausesFinallyInstructions(interp, envPtr, + bodyToken, numHandlers, handlers, finallyToken); + } else { + result = IssueTryClausesFinallyInstructions(interp, envPtr, + bodyToken, numHandlers, handlers, finallyToken); } - result = IssueTryClausesFinallyInstructions(interp, envPtr, bodyToken, - numHandlers, handlers, finallyToken); } /* @@ -3045,7 +3052,8 @@ TclCompileTryCmd( /* *---------------------------------------------------------------------- * - * IssueTryClausesInstructions, IssueTryClausesFinallyInstructions, + * IssueTryClausesInstructions, IssueTryTraplessClausesInstructions, + * IssueTryClausesFinallyInstructions, IssueTryTraplessClausesFinallyInstructions, * IssueTryFinallyInstructions -- * * The code generators for [try]. Split from the parsing engine for @@ -3061,7 +3069,7 @@ IssueTryClausesInstructions( Tcl_Interp *interp, CompileEnv *envPtr, Tcl_Token *bodyToken, - Tcl_Size numHandlers, + Tcl_Size numHandlers, /* Min 1 */ TryHandlerInfo *handlers) { DefineLineInformation; /* TIP #280 */ @@ -3272,7 +3280,7 @@ IssueTryTraplessClausesInstructions( Tcl_Interp *interp, CompileEnv *envPtr, Tcl_Token *bodyToken, - Tcl_Size numHandlers, + Tcl_Size numHandlers, /* Min 1 */ TryHandlerInfo *handlers) { DefineLineInformation; /* TIP #280 */ @@ -3464,7 +3472,7 @@ IssueTryClausesFinallyInstructions( Tcl_Interp *interp, CompileEnv *envPtr, Tcl_Token *bodyToken, - Tcl_Size numHandlers, + Tcl_Size numHandlers, /* Min 1 */ TryHandlerInfo *handlers, Tcl_Token *finallyToken) /* Not NULL */ { @@ -3754,6 +3762,277 @@ IssueTryClausesFinallyInstructions( } 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] = -1; + } + 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= 0 || handlers[i].optionVar >= 0 + || handlers[i].tokenPtr) { + range = MAKE_CATCH_RANGE(); + OP4( BEGIN_CATCH, range); + ExceptionRangeStarts(envPtr, range); + } + if (handlers[i].resultVar >= 0 || handlers[i].optionVar >= 0) { + if (handlers[i].resultVar >= 0) { + OP4( LOAD_SCALAR, resultLocal); + OP4( STORE_SCALAR, handlers[i].resultVar); + OP( POP); + } + if (handlers[i].optionVar >= 0) { + 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 Date: Tue, 29 Apr 2025 13:48:09 +0000 Subject: Indenting and comments, backported from 9.1 --- generic/tclClock.c | 20 ++++++++--------- generic/tclIO.c | 61 +++++++++++++++++++++++++++++--------------------- generic/tclResult.c | 2 +- generic/tclStringObj.c | 6 ++--- tests/clock.test | 2 +- tests/exec.test | 12 +++++----- tests/io.test | 2 +- tests/lseq.test | 12 +++++----- win/tcl.rc | 1 + 9 files changed, 65 insertions(+), 53 deletions(-) diff --git a/generic/tclClock.c b/generic/tclClock.c index ae8f320..d4edec4 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -116,7 +116,7 @@ struct ClockCommand { const char *name; /* The tail of the command name. The full name * is "::tcl::clock::". When NULL marks * the end of the table. */ - Tcl_ObjCmdProc *objCmdProc; /* Function that implements the command. This + Tcl_ObjCmdProc *objCmdProc; /* Function that implements the command. This * will always have the ClockClientData sent * to it, but may well ignore this data. */ CompileProc *compileProc; /* The compiler for the command. */ @@ -341,7 +341,7 @@ ClockConfigureClear( */ static void ClockDeleteCmdProc( - void *clientData) /* Opaque pointer to the client data */ + void *clientData) /* Opaque pointer to the client data */ { ClockClientData *data = (ClockClientData *)clientData; int i; @@ -3277,7 +3277,7 @@ ClockParseFmtScnArgs( ClockFmtScnCmdArgs *opts, /* Result vector: format, locale, timezone... */ TclDateFields *date, /* Extracted date-time corresponding base * (by scan or add) resp. clockval (by format) */ - Tcl_Size objc, /* Parameter count */ + Tcl_Size objc, /* Parameter count */ Tcl_Obj *const objv[], /* Parameter vector */ ClockOperation operation, /* What operation are we doing: format, scan, add */ const char *syntax) /* Syntax of the current command */ @@ -4255,7 +4255,7 @@ ClockCalcRelTime( * and hereafter convert back to TZ, otherwise apply it direct here. */ if (opts->timezoneObj != opts->dataPtr->literals[LIT_GMT]) { - /* + /* * Convert date info structure into UTC seconds and add relative * seconds (happens in commit). */ @@ -4277,7 +4277,7 @@ ClockCalcRelTime( /* restore scanned day of week */ yyDayOfWeek = prevDayOfWeek; } else { - /* + /* * GMT/UTC zone, so no DST and no offsets - apply it here, so that * if time exceeds current date, do the day conversion and leave the * rest of increment in yyRelSeconds (add it later in UTC by commit) @@ -4625,11 +4625,11 @@ ClockSafeCatchCmd( Tcl_Obj *const objv[]) { typedef struct { - int status; /* return code status */ - int flags; /* Each remaining field saves the */ - int returnLevel; /* corresponding field of the Interp */ - int returnCode; /* struct. These fields taken together are */ - Tcl_Obj *errorInfo; /* the "state" of the interp. */ + int status; /* return code status */ + int flags; /* Each remaining field saves the */ + int returnLevel; /* corresponding field of the Interp */ + int returnCode; /* struct. These fields taken together are */ + Tcl_Obj *errorInfo; /* the "state" of the interp. */ Tcl_Obj *errorCode; Tcl_Obj *returnOpts; Tcl_Obj *objResult; diff --git a/generic/tclIO.c b/generic/tclIO.c index 6660e2b..c884934 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -69,7 +69,7 @@ typedef struct GetsState { char **dstPtr; /* Pointer into objPtr's string rep where * next character should be stored. */ Tcl_Encoding encoding; /* The encoding to use to convert raw bytes - * to UTF-8. */ + * to UTF-8. */ ChannelBuffer *bufPtr; /* The current buffer of raw bytes being * emptied. */ Tcl_EncodingState state; /* The encoding state just before the last @@ -336,27 +336,27 @@ static void FreeChannelInternalRep(Tcl_Obj *objPtr); static const Tcl_ObjType chanObjType = { "channel", /* name for this type */ - FreeChannelInternalRep, /* freeIntRepProc */ - DupChannelInternalRep, /* dupIntRepProc */ + FreeChannelInternalRep, /* freeIntRepProc */ + DupChannelInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ NULL, /* setFromAnyProc */ TCL_OBJTYPE_V0 }; -#define ChanSetInternalRep(objPtr, resPtr) \ +#define ChanSetInternalRep(objPtr, resPtr) \ do { \ Tcl_ObjInternalRep ir; \ (resPtr)->refCount++; \ ir.twoPtrValue.ptr1 = (resPtr); \ ir.twoPtrValue.ptr2 = NULL; \ - Tcl_StoreInternalRep((objPtr), &chanObjType, &ir); \ + Tcl_StoreInternalRep((objPtr), &chanObjType, &ir); \ } while (0) -#define ChanGetInternalRep(objPtr, resPtr) \ +#define ChanGetInternalRep(objPtr, resPtr) \ do { \ - const Tcl_ObjInternalRep *irPtr; \ + const Tcl_ObjInternalRep *irPtr; \ irPtr = TclFetchInternalRep((objPtr), &chanObjType); \ - (resPtr) = irPtr ? (ResolvedChanName *)irPtr->twoPtrValue.ptr1 : NULL; \ + (resPtr) = irPtr ? (ResolvedChanName *)irPtr->twoPtrValue.ptr1 : NULL; \ } while (0) #define BUSY_STATE(st, fl) \ @@ -847,7 +847,7 @@ Tcl_CreateCloseHandler( * callback. */ Tcl_CloseProc *proc, /* The callback routine to call when the * channel will be closed. */ - void *clientData) /* Arbitrary data to pass to the close + void *clientData) /* Arbitrary data to pass to the close * callback. */ { ChannelState *statePtr = ((Channel *) chan)->state; @@ -885,7 +885,7 @@ Tcl_DeleteCloseHandler( * callback. */ Tcl_CloseProc *proc, /* The procedure for the callback to * remove. */ - void *clientData) /* The callback data for the callback to + void *clientData) /* The callback data for the callback to * remove. */ { ChannelState *statePtr = ((Channel *) chan)->state; @@ -984,7 +984,7 @@ GetChannelTable( static void DeleteChannelTable( - void *clientData, /* The per-interpreter data structure. */ + void *clientData, /* The per-interpreter data structure. */ Tcl_Interp *interp) /* The interpreter being deleted. */ { Tcl_HashTable *hTblPtr; /* The hash table. */ @@ -2493,7 +2493,7 @@ Tcl_RemoveChannelMode( static ChannelBuffer * AllocChannelBuffer( - Tcl_Size length) /* Desired length of channel buffer. */ + Tcl_Size length) /* Desired length of channel buffer. */ { ChannelBuffer *bufPtr; Tcl_Size n; @@ -4062,7 +4062,7 @@ Tcl_Size Tcl_Write( Tcl_Channel chan, /* The channel to buffer output for. */ const char *src, /* Data to queue in output buffer. */ - Tcl_Size srcLen) /* Length of data in bytes, or TCL_INDEX_NONE for + Tcl_Size srcLen) /* Length of data in bytes, or TCL_INDEX_NONE for * strlen(). */ { /* @@ -4174,7 +4174,7 @@ Tcl_WriteChars( Tcl_Channel chan, /* The channel to buffer output for. */ const char *src, /* UTF-8 characters to queue in output * buffer. */ - Tcl_Size len) /* Length of string in bytes, or TCL_INDEX_NONE for + Tcl_Size len) /* Length of string in bytes, or TCL_INDEX_NONE for * strlen(). */ { Channel *chanPtr = (Channel *) chan; @@ -4352,7 +4352,7 @@ static Tcl_Size Write( Channel *chanPtr, /* The channel to buffer output for. */ const char *src, /* UTF-8 string to write. */ - Tcl_Size srcLen, /* Length of UTF-8 string in bytes. */ + Tcl_Size srcLen, /* Length of UTF-8 string in bytes. */ Tcl_Encoding encoding) { ChannelState *statePtr = chanPtr->state; @@ -5715,7 +5715,7 @@ Tcl_Size Tcl_Read( Tcl_Channel chan, /* The channel from which to read. */ char *dst, /* Where to store input read. */ - Tcl_Size bytesToRead) /* Maximum number of bytes to read. */ + Tcl_Size bytesToRead) /* Maximum number of bytes to read. */ { Channel *chanPtr = (Channel *) chan; ChannelState *statePtr = chanPtr->state; @@ -5760,7 +5760,7 @@ Tcl_Size Tcl_ReadRaw( Tcl_Channel chan, /* The channel from which to read. */ char *readBuf, /* Where to store input read. */ - Tcl_Size bytesToRead) /* Maximum number of bytes to read. */ + Tcl_Size bytesToRead) /* Maximum number of bytes to read. */ { Channel *chanPtr = (Channel *) chan; ChannelState *statePtr = chanPtr->state; @@ -6063,10 +6063,21 @@ DoReadChars( } if (copiedNow < 0) { - if (GotFlag(statePtr, CHANNEL_EOF) || - GotFlag(statePtr, CHANNEL_ENCODING_ERROR)) { + /* + * copiedNow < 0 => no characters decoded in this iteration *AND* + * no source bytes consumed. This can happen if additional data + * needed to decode the next character or an invalid byte sequence + * is encountered before any data was successfully decoded. + * If at EOF, no additional data is available. If an encoding + * error is present, no progress can be made even if more data + * is available (Bug 73bb42fb3f). Either way need to break out + * of the loop. + */ + if (GotFlag(statePtr, CHANNEL_EOF) + || GotFlag(statePtr, CHANNEL_ENCODING_ERROR)) { break; } + if ((GotFlag(statePtr, CHANNEL_NONBLOCKING) || allowShortReads) && GotFlag(statePtr, CHANNEL_BLOCKED)) { break; @@ -6823,7 +6834,7 @@ Tcl_Size Tcl_Ungets( Tcl_Channel chan, /* The channel for which to add the input. */ const char *str, /* The input itself. */ - Tcl_Size len, /* The length of the input. */ + Tcl_Size len, /* The length of the input. */ int atEnd) /* If non-zero, add at end of queue; otherwise * add at head of queue. */ { @@ -7796,7 +7807,7 @@ Tcl_ChannelBuffered( void Tcl_SetChannelBufferSize( Tcl_Channel chan, /* The channel whose buffer size to set. */ - Tcl_Size sz) /* The size to set. */ + Tcl_Size sz) /* The size to set. */ { ChannelState *statePtr; /* State of real channel structure. */ @@ -8870,7 +8881,7 @@ Tcl_CreateChannelHandler( * handler. */ Tcl_ChannelProc *proc, /* Procedure to call for each selected * event. */ - void *clientData) /* Arbitrary data to pass to proc. */ + void *clientData) /* Arbitrary data to pass to proc. */ { ChannelHandler *chPtr; Channel *chanPtr = (Channel *) chan; @@ -8942,7 +8953,7 @@ Tcl_DeleteChannelHandler( Tcl_Channel chan, /* The channel for which to remove the * callback. */ Tcl_ChannelProc *proc, /* The procedure in the callback to delete. */ - void *clientData) /* The client data in the callback to + void *clientData) /* The client data in the callback to * delete. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -9148,7 +9159,7 @@ CreateScriptRecord( void TclChannelEventScriptInvoker( - void *clientData, /* The script+interp record. */ + void *clientData, /* The script+interp record. */ TCL_UNUSED(int) /*mask*/) { EventScriptRecord *esPtr = (EventScriptRecord *)clientData; @@ -10064,7 +10075,7 @@ static Tcl_Size DoRead( Channel *chanPtr, /* The channel from which to read. */ char *dst, /* Where to store input read. */ - Tcl_Size bytesToRead, /* Maximum number of bytes to read. */ + Tcl_Size bytesToRead, /* Maximum number of bytes to read. */ int allowShortReads) /* Allow half-blocking (pipes,sockets) */ { ChannelState *statePtr = chanPtr->state; diff --git a/generic/tclResult.c b/generic/tclResult.c index 5171e5f..2e7d378 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -1034,7 +1034,7 @@ Tcl_GetReturnOptions( if (result == TCL_ERROR) { if (!iPtr->errorInfo) { - /* + /* * No errorLine without errorInfo, e. g. (re)thrown only message, * this shall also avoid transfer of errorLine (if goes to child * interp), because we have anyway nothing excepting message diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 6b589da..7964142 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -724,7 +724,7 @@ Tcl_GetRange( Tcl_Size last) /* Last index of the range. */ { Tcl_Obj *newObjPtr; /* The Tcl object to return that is the new - * range. */ + * range. */ String *stringPtr; Tcl_Size length = 0; @@ -803,8 +803,8 @@ TclGetRange( Tcl_Size first, /* First index of the range. */ Tcl_Size last) /* Last index of the range. */ { - Tcl_Obj *newObjPtr; /* The Tcl object to return that is the new - * range. */ + Tcl_Obj *newObjPtr; /* The Tcl object to return that is the new + * range. */ Tcl_Size length = 0; if (first < 0) { diff --git a/tests/clock.test b/tests/clock.test index 984284b..b69808c 100644 --- a/tests/clock.test +++ b/tests/clock.test @@ -35530,7 +35530,7 @@ test clock-29.1813 {cache consistency when deriving localized formats, bug [2c0f ::msgcat::mcset en_US_roman_xx_yy DATE_FORMAT "%Y|%m|%d" } list [clock format 86400 -format %x -gmt 1 -locale en_US_roman] \ - [clock format 86400 -format %x -gmt 1 -locale en_US_roman_xx] \ + [clock format 86400 -format %x -gmt 1 -locale en_US_roman_xx] \ [clock format 86400 -format %x -gmt 1 -locale en_US_roman_xx_yy] } {01/02/1970 02.01.1970 1970|01|02} # END testcases29 diff --git a/tests/exec.test b/tests/exec.test index 141df07..3225c6d 100644 --- a/tests/exec.test +++ b/tests/exec.test @@ -29,7 +29,7 @@ testConstraint noosxCI [expr {![info exists ::env(MAC_CI)]}] if {[testConstraint win] && ![info exists ::env(CI)] && [info exists ::env(LOCALAPPDATA)] && [file exists [file join $::env(LOCALAPPDATA) "Microsoft" "WindowsApps" "winget.exe"]]} { - testConstraint haveWinget 1 + testConstraint haveWinget 1 } unset -nocomplain path @@ -761,11 +761,11 @@ foreach cmdBuiltin { title type ver vol } { test auto_execok-$cmdBuiltin-1.0 "auto_execok $cmdBuiltin" \ - -constraints win \ - -body { - string equal [auto_execok $cmdBuiltin] \ - "[file normalize $::env(COMSPEC)] /c $cmdBuiltin" - } -result 1 + -constraints win \ + -body { + string equal [auto_execok $cmdBuiltin] \ + "[file normalize $::env(COMSPEC)] /c $cmdBuiltin" + } -result 1 } unset cmdBuiltin diff --git a/tests/io.test b/tests/io.test index f1eeb8c..7b2d99c 100644 --- a/tests/io.test +++ b/tests/io.test @@ -10018,7 +10018,7 @@ test io-bug-73bb43fb-4 { fconfigure stdout -translation binary puts -nonewline "START-"; flush stdout foreach {ch} [split [encoding convertto utf-8 \u30B3] ""] {; # 3 bytes E3 82 B3 - puts -nonewline $ch; flush stdout; if {$ch ne "\xB3"} {after 100} + puts -nonewline $ch; flush stdout; if {$ch ne "\xB3"} {after 100} } puts -nonewline "-DONE"; flush stdout }]] diff --git a/tests/lseq.test b/tests/lseq.test index 168abc8..c8e13eb 100644 --- a/tests/lseq.test +++ b/tests/lseq.test @@ -1067,20 +1067,20 @@ test lseq-bug-f4a4bd7f1070-1 {} -body { test lseq-bug-7d3101bf28-0 {Bug 7d3101bf28 - crash on negative index} -body { list \ - [try [list lindex [lseq 10] -1]] \ - [eval [list lindex [lseq 10] -1]] + [try [list lindex [lseq 10] -1]] \ + [eval [list lindex [lseq 10] -1]] } -result {{} {}} test lseq-bug-7d3101bf28-1 {Bug 7d3101bf28 - crash on out of bounds index} -body { list \ - [try [list lindex [lseq 10] 10]] \ - [eval [list lindex [lseq 10] 10]] + [try [list lindex [lseq 10] 10]] \ + [eval [list lindex [lseq 10] 10]] } -result {{} {}} test lseq-bug-7d3101bf28-2 {Bug 7d3101bf28 - crash on error in index syntax} -body { list \ - [try [list lindex [lseq 10] foo]] \ - [eval [list lindex [lseq 10] foo]] + [try [list lindex [lseq 10] foo]] \ + [eval [list lindex [lseq 10] foo]] } -result {bad index "foo": must be integer?[+-]integer? or end?[+-]integer?} -returnCodes error test lseq-bug-452b103a74-0 {Bug 452b103a74 - crash on nested indices} -body { diff --git a/win/tcl.rc b/win/tcl.rc index 1ea6208..e09dfb3 100644 --- a/win/tcl.rc +++ b/win/tcl.rc @@ -1,3 +1,4 @@ +// // Version Resource Script // -- cgit v0.12 From eb94916257631d37343ff55fe68a941419d8d38a Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Thu, 1 May 2025 05:50:08 +0000 Subject: Add framework for testing nested lists in different list type combinations --- tests/listTypes.test | 180 ++++++++++++++++++++++++++++++++++++++++++--------- 1 file changed, 149 insertions(+), 31 deletions(-) diff --git a/tests/listTypes.test b/tests/listTypes.test index db73635..9e41096 100644 --- a/tests/listTypes.test +++ b/tests/listTypes.test @@ -49,9 +49,13 @@ testConstraint testlistobj [llength [info commands testobj]] namespace eval listtype { variable listTypes {arithseries list repeatedList reversedList spanlist} + variable nestableTypes {list repeatedList reversedList spanlist} # Loop vars etc. variable ltype + variable ltype1 + variable ltype2 + variable ltype3 variable first variable last @@ -60,7 +64,7 @@ namespace eval listtype { # 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 1000 + variable largeListLength 1000; # Multiple of 4 because of assumptions in tests proc getListType {l} { @@ -82,21 +86,26 @@ namespace eval listtype { } # Returns a list of length $largeListLength of the specified type - proc makeList {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 $largeListLength + testlistrep new $len } spanlist { # Spanned list - force span by leaving 10 empty slots in front - testlistrep new $largeListLength 10 + testlistrep new $len 10 } arithseries { - lseq $largeListLength + lseq $len } repeatedList { - lrepeat [expr {$largeListLength/4}] a b c d + lrepeat [expr {$len/4}] a b c d } reversedList { lreverse [makeList list] @@ -106,8 +115,84 @@ namespace eval listtype { return $l } - # Wrapper to generate compiled and uncompiled cases for a test. If $args does - # not contain a -body key, $comment is treated as the test body + # Return first and last elements of a list created with makeList + # assuming default lengths passed to makeList + proc getFirstAndLast {ltype} { + variable largeListLength + switch $ltype { + repeatedList { + set first a + set last d + } + 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 $outerList 0 end-1 + } + repeatedList { + lrepeat $largeListLength $nestedList + } + reversedList { + for {set i 0} {$i < $largeListLength} {incr i} { + lappend outerList $nestedList + } + lreverse $outerList + } + 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] @@ -125,58 +210,91 @@ namespace eval listtype { -body [list try $body] \ {*}$args] - dict append args -setup \n[list proc testxproc {ltype} $body] + # 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" \ + $body] + + dict append args -setup \n[list proc testxproc {} $procbody] dict append args -cleanup "\nrename testxproc {}" - uplevel 1 [list test $id.compiled-proc "$comment (compiled proc)" \ - -body {testxproc $ltype} \ + uplevel 1 [list test $id.proc "$comment (compiled proc)" \ + -body testxproc \ {*}$args] } # llength foreach ltype $listTypes { - testdef llength-$ltype-0 "llength of type $ltype" -body { + 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 + ################################################################ + # lindex tests - single index foreach ltype $listTypes { - switch $ltype { - repeatedList { - set first a - set last d - } - reversedList { - set last 0 - set first [expr {$largeListLength-1}] - } - default { - set first 0 - set last [expr {$largeListLength-1}] - } - } - testdef lindex-$ltype-0 "lindex 0 of type $ltype" -body { + lassign [getFirstAndLast $ltype] first last + testdef lindex-$ltype-shared-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-1 "lindex end of type $ltype" -body { + testdef lindex-$ltype-unshared-0 "lindex 0 of unshared type $ltype" -body { + lindex [makeList $ltype] 0 + } -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-2 "lindex -1 of type $ltype" -body { + 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-2 "lindex -1 of type $ltype" -body { + 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 {} + } + + # lindex tests - nested indices + foreach ltype1 $nestableTypes { + foreach ltype2 $nestableTypes { + foreach ltype3 $listTypes { + lassign [getFirstAndLast $ltype3] first last + testdef ltype-lindex-nested-$ltype1-$ltype2-$ltype3 "lindex nested $ltype1 $ltype2 $ltype3 0" \ + -body { + lindex [makeNestedList $ltype1 $ltype2 $ltype3] 0 0 0 + } -result $first + } + } } + + } # All done -- cgit v0.12 From 3929f9e90eddfc48d815f021fb90e6c48cdfeaae Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 2 May 2025 08:00:32 +0000 Subject: Deprecate (internal) TclVarHashCreateVar() function. It isn't (and shouldn't) be used by any extension. --- generic/tclBinary.c | 2 +- generic/tclInt.decls | 3 +-- generic/tclIntDecls.h | 9 +++++++-- generic/tclIntPlatDecls.h | 2 +- generic/tclObj.c | 4 ++-- generic/tclStringObj.c | 4 ++-- generic/tclStubInit.c | 9 +++++---- generic/tclTest.c | 2 +- generic/tclVar.c | 2 ++ 9 files changed, 22 insertions(+), 15 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 6edebc5..1df01b8 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 */ diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 7e5702c..cb49abd 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -529,8 +529,7 @@ declare 233 { void TclGetSrcInfoForPc(CmdFrame *contextPtr) } -# Exports for VarReform compat: Itcl, XOTcl like to peek into our varTables :( -declare 234 { +declare 234 {deprecated {Not used in Tcl, not in any extension any more}} { Var *TclVarHashCreateVar(TclVarHashTable *tablePtr, const char *key, int *newPtr) } diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 6d9a09a..60810bb 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -491,7 +491,8 @@ EXTERN int TclEvalObjEx(Tcl_Interp *interp, Tcl_Obj *objPtr, /* 233 */ EXTERN void TclGetSrcInfoForPc(CmdFrame *contextPtr); /* 234 */ -EXTERN Var * TclVarHashCreateVar(TclVarHashTable *tablePtr, +TCL_DEPRECATED("Not used in Tcl, not in any extension any more") +Var * TclVarHashCreateVar(TclVarHashTable *tablePtr, const char *key, int *newPtr); /* 235 */ EXTERN void TclInitVarHashTable(TclVarHashTable *tablePtr, @@ -813,7 +814,7 @@ typedef struct TclIntStubs { int (*tclGetNamespaceFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr); /* 231 */ int (*tclEvalObjEx) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, const CmdFrame *invoker, int word); /* 232 */ void (*tclGetSrcInfoForPc) (CmdFrame *contextPtr); /* 233 */ - Var * (*tclVarHashCreateVar) (TclVarHashTable *tablePtr, const char *key, int *newPtr); /* 234 */ + TCL_DEPRECATED_API("Not used in Tcl, not in any extension any more") Var * (*tclVarHashCreateVar) (TclVarHashTable *tablePtr, const char *key, int *newPtr); /* 234 */ void (*tclInitVarHashTable) (TclVarHashTable *tablePtr, Namespace *nsPtr); /* 235 */ void (*reserved236)(void); int (*tclResetCancellation) (Tcl_Interp *interp, int force); /* 237 */ @@ -1272,6 +1273,10 @@ extern const TclIntStubs *tclIntStubsPtr; #define TclObjInterpProc TclGetObjInterpProc() #define TclObjInterpProc2 TclGetObjInterpProc2() +#ifdef TCL_NO_DEPRECATED +# undef TclVarHashCreateVar +#endif + #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h index 9c9fccc..6d15408 100644 --- a/generic/tclIntPlatDecls.h +++ b/generic/tclIntPlatDecls.h @@ -232,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/tclObj.c b/generic/tclObj.c index 8c58c00..c0231e2 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -1658,7 +1658,7 @@ Tcl_GetString( *---------------------------------------------------------------------- */ -#if !defined(TCL_NO_DEPRECATED) +#ifndef TCL_NO_DEPRECATED #undef TclGetStringFromObj char * TclGetStringFromObj( @@ -1702,7 +1702,7 @@ TclGetStringFromObj( } return objPtr->bytes; } -#endif /* !defined(TCL_NO_DEPRECATED) */ +#endif /* !TCL_NO_DEPRECATED */ #undef Tcl_GetStringFromObj char * diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index da5ca6c..5f33950 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -641,7 +641,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 @@ -669,7 +669,7 @@ TclGetUnicodeFromObj( } return stringPtr->unicode; } -#endif /* !defined(TCL_NO_DEPRECATED) */ +#endif /* !TCL_NO_DEPRECATED */ Tcl_UniChar * Tcl_GetUnicodeFromObj( diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 74c709e..4c87ee8 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -70,10 +70,11 @@ # 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 +# define TclVarHashCreateVar 0 #endif #undef Tcl_Close #define Tcl_Close 0 @@ -86,7 +87,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 +96,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,7 +206,7 @@ int TclGetAliasObj(Tcl_Interp *interp, const char *childCmd, } return result; } -#endif /* !defined(TCL_NO_DEPRECATED) */ +#endif /* !TCL_NO_DEPRECATED */ #define TclBN_mp_add mp_add #define TclBN_mp_add_d mp_add_d diff --git a/generic/tclTest.c b/generic/tclTest.c index 5f8d2ae..3a6aafc 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -5747,7 +5747,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; diff --git a/generic/tclVar.c b/generic/tclVar.c index 54da881..18b424f 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -297,6 +297,7 @@ static const Tcl_ObjType parsedVarNameType = { (elem) = irPtr ? (Tcl_Obj *)irPtr->twoPtrValue.ptr2 : NULL; \ } while (0) +#ifndef TCL_NO_DEPRECATED Var * TclVarHashCreateVar( TclVarHashTable *tablePtr, @@ -313,6 +314,7 @@ TclVarHashCreateVar( return varPtr; } +#endif static int LocateArray( -- cgit v0.12 From c815194539f2bcc4a94ab20a37e2358246d6f860 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 2 May 2025 08:21:35 +0000 Subject: Add INST_IS_EMPTY, a surfacing of Tcl_IsEmpty() to bytecode --- generic/tclAssembly.c | 4 ++- generic/tclCompCmdsSZ.c | 28 +++++++++---------- generic/tclCompile.c | 5 ++++ generic/tclCompile.h | 1 + generic/tclExecute.c | 6 ++++ generic/tclOptimize.c | 73 +++++++++++++++++++++++++++++++++++++++++++++++-- 6 files changed, 99 insertions(+), 18 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 321d530..e8e466c 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -387,6 +387,7 @@ static const TalInstDesc TalInstructionTable[] = { {"infoLevelArgs", ASSEM_1BYTE, INST_INFO_LEVEL_ARGS, 1, 1}, {"infoLevelNumber", ASSEM_1BYTE, INST_INFO_LEVEL_NUM, 0, 1}, {"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}, @@ -517,7 +518,8 @@ static const unsigned char NonThrowingByteCodes[] = { 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_SWAP, /* 199 */ + INST_IS_EMPTY /* 204 */ }; /* diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 80704c1..8056c9b 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -221,7 +221,7 @@ TclCompileStringCatCmd( /* Trivial case, no arg */ if (numWords < 2) { - PUSH( ""); + PUSH( ""); return TCL_OK; } @@ -603,8 +603,8 @@ TclCompileStringIsCmd( PUSH( "0"); FWDJUMP( JUMP, over2); FWDLABEL( over); - PUSH( ""); - OP( STR_NEQ); + OP( IS_EMPTY); + OP( LNOT); FWDLABEL( over2); } return TCL_OK; @@ -619,8 +619,7 @@ TclCompileStringIsCmd( case STR_IS_BOOL: if (allowEmpty) { FWDJUMP( JUMP_TRUE, over); - PUSH( ""); - OP( STR_EQ); + OP( IS_EMPTY); FWDJUMP( JUMP, over2); FWDLABEL(over); OP( POP); @@ -634,27 +633,30 @@ TclCompileStringIsCmd( case STR_IS_TRUE: FWDJUMP( JUMP_TRUE, over); if (allowEmpty) { - PUSH( ""); - OP( STR_EQ); + OP( IS_EMPTY); } else { OP( POP); PUSH( "0"); } + FWDJUMP( JUMP, over2); FWDLABEL( over); + // Normalize the boolean value OP( LNOT); OP( LNOT); + FWDLABEL( over2); return TCL_OK; case STR_IS_FALSE: FWDJUMP( JUMP_TRUE, over); if (allowEmpty) { - PUSH( ""); - OP( STR_NEQ); + OP( IS_EMPTY); } else { OP( POP); - PUSH( "1"); + PUSH( "0"); } + FWDJUMP( JUMP, over2); FWDLABEL( over); OP( LNOT); + FWDLABEL( over2); return TCL_OK; default: break; @@ -666,8 +668,7 @@ TclCompileStringIsCmd( if (allowEmpty) { OP( DUP); - PUSH( ""); - OP( STR_EQ); + OP( IS_EMPTY); FWDJUMP( JUMP_TRUE, isEmpty); OP( NUM_TYPE); FWDJUMP( JUMP_TRUE, satisfied); @@ -700,8 +701,7 @@ TclCompileStringIsCmd( OP( DUP); FWDJUMP( JUMP_TRUE, testNumType); OP( POP); - PUSH( ""); - OP( STR_EQ); + OP( IS_EMPTY); FWDJUMP( JUMP, end); STKDELTA(+1); FWDLABEL( testNumType); diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 8ed8db1..dd7af2c 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -944,6 +944,11 @@ InstructionDesc const tclInstructionTable[] = { /* 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 */ {NULL, 0, 0, 0, {OPERAND_NONE}} }; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 1be5fb6..3b06e90 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -893,6 +893,7 @@ enum TclInstruction { INST_TCLOO_ID, INST_DICT_PUT, INST_DICT_REMOVE, + INST_IS_EMPTY, /* The last opcode */ LAST_INST_OPCODE diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 6825e25..0b1057e 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5957,6 +5957,12 @@ TEBCresume( 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); + } + break; /* * End of string-related instructions. diff --git a/generic/tclOptimize.c b/generic/tclOptimize.c index 9e6aa4a..39cbbd4 100644 --- a/generic/tclOptimize.c +++ b/generic/tclOptimize.c @@ -437,6 +437,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. @@ -448,9 +513,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); } /* -- cgit v0.12 From 23dca0cd0d3be49318888b409a03fccf186c2b69 Mon Sep 17 00:00:00 2001 From: oehhar Date: Fri, 2 May 2025 12:31:29 +0000 Subject: [78f44214] Document Tcl_InitStringRep: copy description from TIP 445: better than nothing... --- doc/ObjectType.3 | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/doc/ObjectType.3 b/doc/ObjectType.3 index ca9e0ce..688a04a 100644 --- a/doc/ObjectType.3 +++ b/doc/ObjectType.3 @@ -128,6 +128,17 @@ When \fInumBytes\fR is greater than zero, and the returned pointer is representation. The caller may then choose whether to raise an error or panic. .PP +\fBTcl_InitStringRep\fR performs the function of the existing internal macro +\fBTclInitStringRep\fR, but is extended to return a pointer to the string rep, +and to accept \fBNULL\fR as a value for bytes. +When \fIbytes\fR is \fBNULL\fR and \fIobjPtr\fR has no string rep, an uninitialzed +buffer of numBytes bytes is created for filling by the caller. +When \fIbytes\fR is \fBNULL\fR and \fIobjPtr\fR has a string rep, the string +rep will be truncated to a length of numBytes bytes. +When numBytes is greater than zero, and the returned pointer is \fBNULL\fR, that +indicates a failure to allocate memory for the string representation. +The caller may then choose whether to raise an error or panic. +.PP \fBTcl_HasStringRep\fR returns a boolean indicating whether or not a string rep is currently stored in \fIobjPtr\fR. This is used when the caller wants to act on \fIobjPtr\fR differently -- cgit v0.12 From ef3d4161e58a7bcc21b8227c62275085842ebd50 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 2 May 2025 16:06:36 +0000 Subject: Update comment: INST_RETURN_CODE_BRANCH isn't needed in asm any more --- generic/tclAssembly.c | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 68e3f1b..51749bc 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 (?) - *- returnCodeBranch1, returnCodeBranch *- tclooNext, tclooNextClass */ -- cgit v0.12 From 6e4e90b77a4b4ca5d91d0eb62f6d053f21cfdd98 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 2 May 2025 16:57:37 +0000 Subject: typo --- doc/Object.3 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/Object.3 b/doc/Object.3 index 0dedbf9..5503599 100644 --- a/doc/Object.3 +++ b/doc/Object.3 @@ -28,7 +28,7 @@ Tcl_Obj * int \fBTcl_IsShared\fR(\fIobjPtr\fR) .sp -\fBTcl_InvalidateStringRep\fR(\fIobjPtr\fR)3 +\fBTcl_InvalidateStringRep\fR(\fIobjPtr\fR) .fi .SH ARGUMENTS .AS Tcl_Obj *objPtr -- cgit v0.12 From 51df805a81c05fd8dbf59651929610a1a73c81e9 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 2 May 2025 17:57:36 +0000 Subject: Rework overflow test so it happens in a valid range. --- generic/tclArithSeries.c | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/generic/tclArithSeries.c b/generic/tclArithSeries.c index 930f52a..211c8d4 100755 --- a/generic/tclArithSeries.c +++ b/generic/tclArithSeries.c @@ -1148,15 +1148,17 @@ UpdateStringOfArithSeries( char tmp[TCL_DOUBLE_SPACE + 2]; for (i = 0; i < arithSeriesRepPtr->len; i++) { double d = ArithSeriesIndexDbl(arithSeriesRepPtr, i); + Tcl_Size elen; tmp[0] = '\0'; Tcl_PrintDouble(NULL,d,tmp); - bytlen += strlen(tmp); - if (bytlen > TCL_SIZE_MAX) { + elen = strlen(tmp); + if (bytlen > TCL_SIZE_MAX - elen) { /* overflow, todo: check we could use some representation instead of the panic * to signal it is too large for string representation, because too heavy */ Tcl_Panic("UpdateStringOfArithSeries: too large to represent"); } + bytlen += elen; } } bytlen += arithSeriesRepPtr->len; // Space for each separator -- cgit v0.12 From 47dd25a0aa02c3c92004f90b032bd7a9a1f6f7ed Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 2 May 2025 18:29:24 +0000 Subject: Use Tcl_InitStringRep() as intended. --- generic/tclArithSeries.c | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/generic/tclArithSeries.c b/generic/tclArithSeries.c index 211c8d4..2a79416 100755 --- a/generic/tclArithSeries.c +++ b/generic/tclArithSeries.c @@ -1126,11 +1126,11 @@ UpdateStringOfArithSeries( { ArithSeries *arithSeriesRepPtr = (ArithSeries *) arithSeriesObjPtr->internalRep.twoPtrValue.ptr1; - char *p; + char *p, *srep; Tcl_Size i, bytlen = 0; - if (!arithSeriesRepPtr->len) { - TclInitEmptyStringRep(arithSeriesObjPtr); + if (arithSeriesRepPtr->len == 0) { + (void)Tcl_InitStringRep(arithSeriesObjPtr, NULL, 0); return; } @@ -1167,7 +1167,7 @@ UpdateStringOfArithSeries( * Pass 2: generate the string repr. */ - p = Tcl_InitStringRep(arithSeriesObjPtr, NULL, bytlen); + p = srep = Tcl_InitStringRep(arithSeriesObjPtr, NULL, bytlen); if (!arithSeriesRepPtr->isDouble) { for (i = 0; i < arithSeriesRepPtr->len; i++) { Tcl_WideInt d = ArithSeriesIndexInt(arithSeriesRepPtr, i); @@ -1186,8 +1186,7 @@ UpdateStringOfArithSeries( *p++ = ' '; } } - *(--p) = '\0'; - arithSeriesObjPtr->length = p - arithSeriesObjPtr->bytes; + (void) Tcl_InitStringRep(arithSeriesObjPtr, NULL, (--p - srep)); } /* -- cgit v0.12 From 4ddbdc2f1bd38802fab14ae7941a957deab8f5e3 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sat, 3 May 2025 12:05:05 +0000 Subject: Implement lrangeType Tcl_Obj --- generic/tclCmdIL.c | 18 +-- generic/tclExecute.c | 11 +- generic/tclInt.h | 10 +- generic/tclListObj.c | 2 +- generic/tclListTypes.c | 303 ++++++++++++++++++++++++++++++++++++++++++++++++- generic/tclTestObj.c | 9 ++ tests/listTypes.test | 108 +++++++++++++++++- 7 files changed, 422 insertions(+), 39 deletions(-) diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 6eb5f93..c6178a0 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -2752,22 +2752,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; } /* diff --git a/generic/tclExecute.c b/generic/tclExecute.c index c6adfd6..64acbd3 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5026,14 +5026,9 @@ TEBCresume( fromIdx = TclIndexDecode(fromIdx, 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) { + if (Tcl_ListObjRange(interp, valuePtr, fromIdx, toIdx, &objResultPtr) != + TCL_OK) { + objResultPtr = NULL; CACHE_STACK_INFO(); TRACE_ERROR(interp); goto gotError; diff --git a/generic/tclInt.h b/generic/tclInt.h index 407078d..4bfa33b 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1197,12 +1197,10 @@ TclObjTypeInOperator( /* Functions related to abstract list implementations */ MODULE_SCOPE int Tcl_ListObjReverse(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Obj **resultPtrPtr); -MODULE_SCOPE int Tcl_ListObjRepeat( - Tcl_Interp *interp, - Tcl_Size repeatCount, - Tcl_Size objc, - Tcl_Obj *const objv[], - Tcl_Obj **resultPtrPtr); +MODULE_SCOPE int Tcl_ListObjRepeat(Tcl_Interp *interp, Tcl_Size repeatCount, + Tcl_Size objc, Tcl_Obj *const objv[], Tcl_Obj **resultPtrPtr); +MODULE_SCOPE int Tcl_ListObjRange(Tcl_Interp *interp, Tcl_Obj *objPtr, + Tcl_Size start, Tcl_Size end, Tcl_Obj **resultPtrPtr); #endif /* TCL_MAJOR_VERSION > 8 */ diff --git a/generic/tclListObj.c b/generic/tclListObj.c index d11fac9..3954299 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -1457,7 +1457,7 @@ 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 */ diff --git a/generic/tclListTypes.c b/generic/tclListTypes.c index a2ba2f4..094f08b 100644 --- a/generic/tclListTypes.c +++ b/generic/tclListTypes.c @@ -20,7 +20,9 @@ */ #define LREVERSE_LENGTH_THRESHOLD 100 #define LREPEAT_LENGTH_THRESHOLD 100 +#define LRANGE_LENGTH_THRESHOLD 100 +/* TODO - no used */ static inline int TclAbstractListLength(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Size *lengthPtr) { @@ -191,6 +193,8 @@ static void TclAbstractListUpdateString (Tcl_Obj *objPtr) } /* + * lrepeatType - + * * ------------------------------------------------------------------------ * lreverseType is an abstract list type that contains the same elements as a * given list but in reverse order. Implementation is straightforward with the @@ -333,7 +337,7 @@ Tcl_ListObjReverse( Tcl_Obj *resultPtr; if (elemc >= LREVERSE_LENGTH_THRESHOLD || objPtr->typePtr != &tclListType) { - resultPtr = Tcl_NewObj(); + TclNewObj(resultPtr); TclInvalidateStringRep(resultPtr); Tcl_IncrRefCount(objPtr); @@ -373,6 +377,8 @@ Tcl_ListObjReverse( } /* + * lrepeatType - + * * ------------------------------------------------------------------------ * lrepeatType is an abstract list type that repeated elements. * Implementation is straightforward with the elements stored in @@ -389,7 +395,7 @@ static Tcl_ObjTypeIndexProc LrepeatTypeIndex; /* * IMPORTANT - current implementation is read-only. That is, the - * functions below that set or modify elements are not NULL. If you change + * 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. */ @@ -491,7 +497,7 @@ Tcl_ListObjRepeat( Tcl_Size totalElems = objc * repeatCount; if (totalElems == 0) { - *resultPtrPtr = Tcl_NewObj(); + TclNewObj(*resultPtrPtr); return TCL_OK; } @@ -506,7 +512,7 @@ Tcl_ListObjRepeat( Tcl_Obj *resultPtr; if (totalElems >= LREPEAT_LENGTH_THRESHOLD) { TclObjArray *arrayPtr = TclObjArrayNew(objc, objv); - resultPtr = Tcl_NewObj(); + TclNewObj(resultPtr); arrayPtr->refCount++; TclInvalidateStringRep(resultPtr); resultPtr->internalRep.ptrAndSize.ptr = arrayPtr; @@ -557,3 +563,292 @@ Tcl_ListObjRepeat( *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 and end index. + * The type is a descriptor stored in the otherValuePtr field of the Tcl_Obj. + * ------------------------------------------------------------------------ + */ +typedef struct LrangeRep { + Tcl_Obj *srcListPtr; /* Source list */ + Tcl_Size refCount; /* Reference count */ + Tcl_Size start; /* Start index */ + Tcl_Size end; /* End index */ +} LrangeRep; + +static void LrangeFreeIntrep(Tcl_Obj *objPtr); +static void LrangeDupIntrep(Tcl_Obj *srcObj, Tcl_Obj *dupObj); +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 - TODO */ +}; + +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 *sourcePtr, /* Source for the range operation */ + Tcl_Size start, /* Start of range */ + Tcl_Size end, /* End of range */ + Tcl_Obj **resultPtrPtr) /* Location to store range object */ +{ + /* Create a lrangeType referencing the original source list */ + LrangeRep *repPtr = (LrangeRep *)Tcl_Alloc(sizeof(LrangeRep)); + Tcl_Obj *resultPtr; + Tcl_IncrRefCount(sourcePtr); + repPtr->srcListPtr = sourcePtr; + repPtr->refCount = 1; + repPtr->start = start; + repPtr->end = end; + TclNewObj(resultPtr); + TclInvalidateStringRep(resultPtr); + resultPtr->internalRep.otherValuePtr = repPtr; + resultPtr->typePtr = &lrangeType; + *resultPtrPtr = resultPtr; + return TCL_OK; + +} + +void +LrangeFreeIntrep(Tcl_Obj *objPtr) +{ + LrangeRep *repPtr = (LrangeRep *)objPtr->internalRep.otherValuePtr; + if (repPtr->refCount <= 1) { + Tcl_DecrRefCount(repPtr->srcListPtr); + Tcl_Free(repPtr); + } else { + repPtr->refCount--; + } +} + +void +LrangeDupIntrep(Tcl_Obj *srcObj, Tcl_Obj *dupObj) +{ + LrangeRep *repPtr = (LrangeRep *)srcObj->internalRep.otherValuePtr; + repPtr->refCount++; + dupObj->internalRep.otherValuePtr = repPtr; + dupObj->typePtr = srcObj->typePtr; +} + +/* Implementation of Tcl_ObjType.lengthProc for lrangeType */ +Tcl_Size +LrangeTypeLength(Tcl_Obj *objPtr) +{ + LrangeRep *repPtr = (LrangeRep *)objPtr->internalRep.otherValuePtr; + return repPtr->end - repPtr->start + 1; +} + +/* Implementation of Tcl_ObjType.indexProc for lrangeType */ +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.otherValuePtr; + Tcl_Size len = repPtr->end - repPtr->start + 1; + if (index < 0 || index >= len) { + *elemPtrPtr = NULL; + return TCL_OK; + } + return Tcl_ListObjIndex( + interp, repPtr->srcListPtr, repPtr->start + index, elemPtrPtr); +} + +/* Implementation of Tcl_ObjType.sliceProc for lrangeType */ +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); + + LrangeRep *repPtr = (LrangeRep *)objPtr->internalRep.otherValuePtr; + Tcl_Size len = repPtr->end - repPtr->start + 1; + + if (start < 0) { + start = 0; + } + if (end >= len) { + end = len - 1; + } + if (start > end) { + TclNewObj(*resultPtrPtr); + return TCL_OK; + } + + + /* + * If the original source list was also a lrangeType, we can reference + * *its* source directly. Moreover, if objPtr is unshared, reuse it. + * Do this recursively until we reach a non-lrangeType. + */ + Tcl_Obj *sourcePtr = repPtr->srcListPtr; + while (sourcePtr->typePtr == &lrangeType) { + LrangeRep *sourceRepPtr = (LrangeRep *)sourcePtr->internalRep.otherValuePtr; + start += sourceRepPtr->start; + end += sourceRepPtr->start; + sourcePtr = sourceRepPtr->srcListPtr; + } + /* + * At this point, sourcePtr is a non-lrangeType that will be the source + * Tcl_Obj for the returned object. The start and end indices are indices + * into this. Note it is possible that sourcePtr is repPtr->srcListPtr. + */ + + /* + * 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 (TclListObjLength(interp, sourcePtr, &len) != TCL_OK) { + /* Cannot fail because how rangeType's are constructed but ... */ + return TCL_ERROR; + } + Tcl_Size rangeLen = end - start + 1; + if (objPtr->typePtr == &tclListType || + !LrangeMeetsLengthCriteria(rangeLen, len)) { + /* Conditions not met, create non-abstract list */ + *resultPtrPtr = TclListObjRange(interp, objPtr, start, end); + return *resultPtrPtr ? TCL_OK : TCL_ERROR; + } + + if (!Tcl_IsShared(objPtr) && repPtr->refCount < 2) { + /* Reuse this objPtr */ + repPtr->start = start; + repPtr->end = end; + repPtr->srcListPtr = sourcePtr; + Tcl_IncrRefCount(sourcePtr); + Tcl_InvalidateStringRep(objPtr); + *resultPtrPtr = objPtr; + return TCL_OK; + } + else { + return LrangeNew(sourcePtr, start, end, 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 may be the same as objPtr, + * 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. + * + *------------------------------------------------------------------------ + */ +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; + + result = TclListObjLength(interp, objPtr, &srcLen); + if (result != TCL_OK) { + return result; + } + + if (start < 0) { + start = 0; + } + if (end >= srcLen) { + end = srcLen - 1; + } + if (start > end) { + TclNewObj(*resultPtrPtr); + return TCL_OK; + } + + /* + * If the list is an AbstractList with a specialized slice, use it. + * Note this includes rangeType itself. + */ + if (TclObjTypeHasProc(objPtr, sliceProc)) { + return TclObjTypeSlice(interp, objPtr, start, end, resultPtrPtr); + } + + /* + * 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. + */ + Tcl_Size rangeLen = end - start + 1; + if (objPtr->typePtr == &tclListType || + !LrangeMeetsLengthCriteria(rangeLen, srcLen)) { + /* Conditions not met, create non-abstract list */ + *resultPtrPtr = TclListObjRange(interp, objPtr, start, end); + return *resultPtrPtr ? TCL_OK : TCL_ERROR; + } + + /* Create a lrangeType referencing the original source list */ + return LrangeNew(objPtr, start, end, resultPtrPtr); +} + + + diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index f73483b..5d9354a 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -1104,6 +1104,7 @@ TestobjCmd( static const char *const subcommands[] = { "freeallvars", "bug3598580", "buge58d7e19e9", "types", "objtype", "newobj", "set", + "objrefcount", "assign", "convert", "duplicate", "invalidateStringRep", "refcount", "type", NULL @@ -1111,6 +1112,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 +1210,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; diff --git a/tests/listTypes.test b/tests/listTypes.test index 9e41096..e81a538 100644 --- a/tests/listTypes.test +++ b/tests/listTypes.test @@ -58,6 +58,8 @@ namespace eval listtype { variable ltype3 variable first variable last + variable indices + variable result # Internal representation produced by a list operation may depend on list # length. This is controlled by the *_LENGTH_THRESHOLD values in tclListTypes.c. @@ -66,7 +68,6 @@ namespace eval listtype { variable smallListLength 10 variable largeListLength 1000; # Multiple of 4 because of assumptions in tests - proc getListType {l} { set ltype [testobj objtype $l] if {$ltype eq "list"} { @@ -278,21 +279,116 @@ namespace eval listtype { 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 + # 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 - testdef ltype-lindex-nested-$ltype1-$ltype2-$ltype3 "lindex nested $ltype1 $ltype2 $ltype3 0" \ - -body { - lindex [makeNestedList $ltype1 $ltype2 $ltype3] 0 0 0 - } -result $first + 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 ltype-lindex-nested-onearg-$ltype1-$ltype2-$ltype3 "lindex nested single indices argument $ltype1 $ltype2 $ltype3 $indices" \ + -body { + variable indices + lindex [makeNestedList $ltype1 $ltype2 $ltype3] $indices + } -result $result + + testdef ltype-lindex-nested-multiarg-$ltype1-$ltype2-$ltype3 "lindex nested multiple index arguments $ltype1 $ltype2 $ltype3 $indices" \ + -body { + variable indices + lindex [makeNestedList $ltype1 $ltype2 $ltype3] {*}$indices + } -result $result + } } } } + ################################################################ + # 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 + # lassign result is always a spanlist except for arithseries which + # implements an optimized range operation. + foreach ltype $listTypes { + } + + ################################################################ + # ledit tests - TBD + ################################################################ + # lreplace tests - TBD + ################################################################ + # linsert tests - TBD + ################################################################ + # lreverse tests - TBD + ################################################################ + # lsearch tests - TBD + ################################################################ + # lset tests - TBD + ################################################################ + # lsort tests - TBD + ################################################################ + # foreach tests - TBD + ################################################################ + # lmap tests - TBD + ################################################################ + # lrange tests - TBD + ################################################################ + # concat tests - TBD + ################################################################ + # join tests - TBD + ################################################################ + # lrepeat tests - TBD + ################################################################ + # lpop tests - TBD + ################################################################ + # lremove tests - TBD + } -- cgit v0.12 From dc785821c0ecc44a7ce926d9aba35e0012a2f5ef Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sun, 4 May 2025 06:51:29 +0000 Subject: Use rangeList Tcl_ObjType for lassign of large lists --- generic/tclCmdIL.c | 22 +++++++--------------- generic/tclListTypes.c | 19 +------------------ tests/listTypes.test | 49 ++++++++++++++++++++++++++++++++++++++++++++----- 3 files changed, 52 insertions(+), 38 deletions(-) diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index c6178a0..5e706d0 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -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; diff --git a/generic/tclListTypes.c b/generic/tclListTypes.c index 094f08b..a373166 100644 --- a/generic/tclListTypes.c +++ b/generic/tclListTypes.c @@ -22,20 +22,6 @@ #define LREPEAT_LENGTH_THRESHOLD 100 #define LRANGE_LENGTH_THRESHOLD 100 -/* TODO - no used */ -static inline int -TclAbstractListLength(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Size *lengthPtr) -{ - int ret; - if (TclObjTypeHasProc(objPtr, lengthProc)) { - *lengthPtr = TclObjTypeLength(objPtr); - ret = TCL_OK; - } else { - ret = TclListObjLength(interp, objPtr, lengthPtr); - } - return ret; -} - /* * TclObjArray stores a reference counted Tcl_Obj array. */ @@ -848,7 +834,4 @@ Tcl_ListObjRange( /* Create a lrangeType referencing the original source list */ return LrangeNew(objPtr, start, end, resultPtrPtr); -} - - - +} \ No newline at end of file diff --git a/tests/listTypes.test b/tests/listTypes.test index e81a538..4f4e88e 100644 --- a/tests/listTypes.test +++ b/tests/listTypes.test @@ -48,8 +48,8 @@ testConstraint testobj [llength [info commands testobj]] testConstraint testlistobj [llength [info commands testobj]] namespace eval listtype { - variable listTypes {arithseries list repeatedList reversedList spanlist} - variable nestableTypes {list repeatedList reversedList spanlist} + variable listTypes {arithseries list rangeList repeatedList reversedList spanlist} + variable nestableTypes {list rangeList repeatedList reversedList spanlist} # Loop vars etc. variable ltype @@ -105,11 +105,16 @@ namespace eval listtype { 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] + lreverse [makeList list $len] } }] assertListType $l $type @@ -125,6 +130,7 @@ namespace eval listtype { set first a set last d } + rangeList - reversedList { set last 0 set first [expr {$largeListLength-1}] @@ -155,6 +161,7 @@ namespace eval listtype { 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 { @@ -166,6 +173,14 @@ namespace eval listtype { } 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 + lrange [lreverse $outerList] 0 end-1 + } default { error "List type $thisType cannot nest" } @@ -353,9 +368,33 @@ namespace eval listtype { ################################################################ # lassign tests - # lassign result is always a spanlist except for arithseries which - # implements an optimized range operation. + # 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-0 "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-0 "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-0 "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]] } ################################################################ -- cgit v0.12 From c7d153cbbbfb7fd6c4160959eeb59ab22e8d5f9b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 5 May 2025 06:53:48 +0000 Subject: Missing TclOOM() calls, which produce a panic when Tcl_InitStringRep() fails --- generic/tclArithSeries.c | 2 ++ generic/tclIndexObj.c | 3 ++- generic/tclTestABSList.c | 7 ++++--- macosx/tclMacOSXFCmd.c | 2 +- 4 files changed, 9 insertions(+), 5 deletions(-) diff --git a/generic/tclArithSeries.c b/generic/tclArithSeries.c index 36bc7f9..244c2a8 100755 --- a/generic/tclArithSeries.c +++ b/generic/tclArithSeries.c @@ -1192,6 +1192,8 @@ UpdateStringOfArithSeries( */ p = srep = Tcl_InitStringRep(arithSeriesObjPtr, NULL, bytlen); + TclOOM(p, bytlen+1); + if (!arithSeriesRepPtr->isDouble) { for (i = 0; i < arithSeriesRepPtr->len; i++) { Tcl_WideInt d = ArithSeriesIndexInt(arithSeriesRepPtr, i); diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index 2dbc6f6..2c2bd35 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -388,8 +388,9 @@ UpdateStringOfIndex( { IndexRep *indexRep = (IndexRep *)TclFetchInternalRep(objPtr, &tclIndexType)->twoPtrValue.ptr1; const char *indexStr = EXPAND_OF(indexRep); + size_t len = strlen(indexStr); - Tcl_InitStringRep(objPtr, indexStr, strlen(indexStr)); + TclOOM(Tcl_InitStringRep(objPtr, indexStr, len), len+1); } /* diff --git a/generic/tclTestABSList.c b/generic/tclTestABSList.c index 7e853e4..8e306c6 100644 --- a/generic/tclTestABSList.c +++ b/generic/tclTestABSList.c @@ -1047,7 +1047,7 @@ UpdateStringOfLgen(Tcl_Obj *objPtr) LgenSeries *lgenSeriesRepPtr; Tcl_Obj *element; Tcl_Size i; - size_t bytlen; + Tcl_Size bytlen; Tcl_Obj *tmpstr = Tcl_NewObj(); lgenSeriesRepPtr = (LgenSeries*)objPtr->internalRep.twoPtrValue.ptr1; @@ -1062,8 +1062,9 @@ UpdateStringOfLgen(Tcl_Obj *objPtr) } } - bytlen = Tcl_GetCharLength(tmpstr); - Tcl_InitStringRep(objPtr, Tcl_GetString(tmpstr), bytlen); + char *str = Tcl_GetStringFromObj(tmpstr, &bytlen); + + TclOOM(Tcl_InitStringRep(objPtr, str, bytlen), bytlen+1); Tcl_DecrRefCount(tmpstr); return; diff --git a/macosx/tclMacOSXFCmd.c b/macosx/tclMacOSXFCmd.c index 16a728f..251abf3 100644 --- a/macosx/tclMacOSXFCmd.c +++ b/macosx/tclMacOSXFCmd.c @@ -687,7 +687,7 @@ UpdateStringOfOSType( Tcl_Encoding encoding; char src[5]; - TclOOM(dst, size); + TclOOM(dst, size+1); src[0] = (char) (osType >> 24); src[1] = (char) (osType >> 16); -- cgit v0.12 From ab8975174d31a3c53fb206a3e075613e60738dfa Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 5 May 2025 09:14:42 +0000 Subject: Proposed fix for [8ffd8cabd1]: "encoding system": wrong result without manifest Extracted from TIP 716 implementation --- win/tclWinInit.c | 62 ++++++++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 60 insertions(+), 2 deletions(-) diff --git a/win/tclWinInit.c b/win/tclWinInit.c index 141aff1..079b1c8 100644 --- a/win/tclWinInit.c +++ b/win/tclWinInit.c @@ -63,6 +63,62 @@ static ProcessGlobalValue defaultLibraryDir = {0, 0, NULL, NULL, InitializeDefaultLibraryDir, NULL, NULL}; static ProcessGlobalValue sourceLibraryDir = {0, 0, NULL, NULL, InitializeSourceLibraryDir, NULL, NULL}; + + +/* + * TclpGetWindowsVersionOnce -- + * + * Callback to retrieve Windows version information. To be invoked only + * through InitOnceExecuteOnce for thread safety. + * + * Results: + * None. + */ +static BOOL CALLBACK TclpGetWindowsVersionOnce( + TCL_UNUSED(PINIT_ONCE), + TCL_UNUSED(PVOID), + PVOID *lpContext) +{ + typedef int(__stdcall getVersionProc)(void *); + static OSVERSIONINFOW osInfo; + + /* + * GetVersionExW will not return the "real" Windows version so use + * RtlGetVersion if available and falling back. + */ + HMODULE handle = GetModuleHandleW(L"NTDLL"); + getVersionProc *getVersion = + (getVersionProc *)(void *)GetProcAddress(handle, "RtlGetVersion"); + + osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW); + if (getVersion == NULL || getVersion(&osInfo)) { + if (!GetVersionExW(&osInfo)) { + /* Should never happen but ...*/ + return FALSE; + } + } + *lpContext = (LPVOID)&osInfo; + return TRUE; +} + +/* + * TclpGetWindowsVersion -- + * + * Returns a pointer to the OSVERSIONINFOW structure containing the + * version information for the current Windows version. + * + * Results: + * Pointer to OSVERSIONINFOW structure. + */ +static const OSVERSIONINFOW *TclpGetWindowsVersion(void) +{ + static INIT_ONCE osInfoOnce = INIT_ONCE_STATIC_INIT; + OSVERSIONINFOW *osInfoPtr = NULL; + BOOL result = InitOnceExecuteOnce( + &osInfoOnce, TclpGetWindowsVersionOnce, NULL, (LPVOID *)&osInfoPtr); + return result ? osInfoPtr : NULL; +} + /* *--------------------------------------------------------------------------- @@ -401,7 +457,9 @@ const char * Tcl_GetEncodingNameFromEnvironment( Tcl_DString *bufPtr) { - UINT acp = GetACP(); + const OSVERSIONINFOW *osInfoPtr = TclpGetWindowsVersion(); + UINT acp = (!osInfoPtr || osInfoPtr->dwBuildNumber < 18362) + ? GetACP() : CP_UTF8; Tcl_DStringInit(bufPtr); if (acp == CP_UTF8) { @@ -409,7 +467,7 @@ Tcl_GetEncodingNameFromEnvironment( } else { Tcl_DStringSetLength(bufPtr, 2 + TCL_INTEGER_SPACE); snprintf(Tcl_DStringValue(bufPtr), 2 + TCL_INTEGER_SPACE, "cp%d", - GetACP()); + acp); Tcl_DStringSetLength(bufPtr, strlen(Tcl_DStringValue(bufPtr))); } return Tcl_DStringValue(bufPtr); -- cgit v0.12 From 5a7a1ab3794283f637682316cd7df212adf62888 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 5 May 2025 11:44:27 +0000 Subject: Don't let tests pass out-of-range argument to TclMSB(). --- generic/tclTest.c | 5 +++++ tests/brodnik.test | 7 ++++++- 2 files changed, 11 insertions(+), 1 deletion(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index 58b15f1..b120190 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -4030,6 +4030,11 @@ TestmsbObjCmd( if (TCL_OK != Tcl_GetWideIntFromObj(interp, objv[1], &w)) { return TCL_ERROR; } + if (w <= 0) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("argument must be positive",-1)); + return TCL_ERROR; + } Tcl_SetObjResult(interp, Tcl_NewIntObj(TclMSB((unsigned long long)w))); return TCL_OK; } diff --git a/tests/brodnik.test b/tests/brodnik.test index e3d9ed3..281a3c9 100644 --- a/tests/brodnik.test +++ b/tests/brodnik.test @@ -31,8 +31,13 @@ namespace eval ::tcl::test::brodnik { } } + # Test out-of-range rejection + test brodnik-1.0 {TclMSB correctness} -constraints testmsb -body { + testmsb 0 + } -returnCodes error -match glob -result * + # Tests for values with MSB in the low block - variable v 0 + variable v 1 while {$v < 1<<8} { test brodnik-1.$v {TclMSB correctness} testmsb { testmsb $v -- cgit v0.12 From c489ce30009c115b7ba1b50bae01f7fddb31435c Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 5 May 2025 14:43:47 +0000 Subject: Clean up a bit --- generic/tclAssembly.c | 88 +++++++-------- generic/tclCompCmds.c | 75 ++++++------- generic/tclCompCmdsGR.c | 15 +-- generic/tclCompCmdsSZ.c | 105 +++++++++--------- generic/tclCompExpr.c | 276 ++++++++++++++++++++++++----------------------- generic/tclCompUtils.h | 19 ++-- generic/tclCompile.c | 71 +++++++----- generic/tclCompile.h | 13 ++- generic/tclDisassemble.c | 64 +++++++---- 9 files changed, 396 insertions(+), 330 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 51749bc..ef1f3c9 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -743,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 @@ -993,7 +994,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 */ - Tcl_Size 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); @@ -1109,7 +1111,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 */ @@ -1341,8 +1344,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; } @@ -1608,8 +1611,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; @@ -1665,7 +1668,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: @@ -2151,7 +2155,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; @@ -2374,7 +2379,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; @@ -2435,13 +2440,11 @@ CheckNamespaceQualifiers( static int CheckOneByte( Tcl_Interp* interp, /* Tcl interpreter for error reporting */ - Tcl_Size 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; } @@ -2469,13 +2472,11 @@ CheckOneByte( static int CheckSignedOneByte( Tcl_Interp* interp, /* Tcl interpreter for error reporting */ - Tcl_Size 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; } @@ -2502,13 +2503,11 @@ CheckSignedOneByte( static int CheckNonNegative( Tcl_Interp* interp, /* Tcl interpreter for error reporting */ - Tcl_Size value) /* Value to check */ + Tcl_Size value) /* Value to check */ { - Tcl_Obj* result; /* Error message */ - if (value < 0 || value > INT_MAX) { - result = Tcl_NewStringObj("operand must be nonnegative", -1); - Tcl_SetObjResult(interp, result); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "operand must be nonnegative", TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NONNEGATIVE", (char *)NULL); return TCL_ERROR; } @@ -2535,13 +2534,11 @@ CheckNonNegative( static int CheckStrictlyPositive( Tcl_Interp* interp, /* Tcl interpreter for error reporting */ - Tcl_Size value) /* Value to check */ + Tcl_Size value) /* Value to check */ { - Tcl_Obj* result; /* Error message */ - if (value <= 0 || value > INT_MAX) { - result = Tcl_NewStringObj("operand must be positive", -1); - Tcl_SetObjResult(interp, result); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "operand must be positive", TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "ASSEM", "POSITIVE", (char *)NULL); return TCL_ERROR; } @@ -3112,9 +3109,9 @@ ResolveJumpTableTargets( Tcl_SetHashValue(realJumpEntryPtr, INT2PTR(jumpTargetBBPtr->startOffset - bbPtr->jumpOffset)); - } - DEBUG_PRINT("}\n"); - } + } + DEBUG_PRINT("}\n"); + } } /* @@ -3401,7 +3398,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 @@ -3430,7 +3428,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); @@ -3449,7 +3448,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); @@ -3722,7 +3722,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); } @@ -3781,7 +3781,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); } @@ -3858,7 +3859,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); @@ -3902,7 +3904,7 @@ BuildExceptionRanges( int catchDepth = 0; /* Current catch depth */ int maxCatchDepth = 0; /* Maximum catch depth in the program */ BasicBlock** catches; /* Stack of catches in progress */ - Tcl_Size* catchIndices; /* Indices of the exception ranges of catches + Tcl_Size* catchIndices; /* Indices of the exception ranges of catches * in progress */ int i; @@ -3945,7 +3947,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); } @@ -3986,7 +3988,7 @@ UnstackExpiredCatches( int catchDepth, /* Depth of nesting of catches prior to entry * to this block */ BasicBlock **catches, /* Array of catch contexts */ - Tcl_Size *catchIndices) /* Indices of the exception ranges + Tcl_Size *catchIndices) /* Indices of the exception ranges * corresponding to the catch contexts */ { ExceptionRange* range; /* Exception range for a specific catch */ @@ -4092,7 +4094,7 @@ StackFreshCatches( int catchDepth, /* Depth of nesting of catches prior to entry * to this block */ BasicBlock** catches, /* Array of catch contexts */ - Tcl_Size* catchIndices) /* Indices of the exception ranges + Tcl_Size* catchIndices) /* Indices of the exception ranges * corresponding to the catch contexts */ { CompileEnv* envPtr = assemEnvPtr->envPtr; diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index b66c554..30887c4 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -619,7 +619,7 @@ TclCompileCatchCmd( * refer to local scalars. */ - resultIndex = optsIndex = -1; + resultIndex = optsIndex = TCL_INDEX_NONE; cmdTokenPtr = TokenAfter(parsePtr->tokenPtr); if (numWords >= 3) { resultNameTokenPtr = TokenAfter(cmdTokenPtr); @@ -709,7 +709,7 @@ TclCompileCatchCmd( * before INST_END_CATCH */ - if (optsIndex != -1) { + if (optsIndex != TCL_INDEX_NONE) { OP( PUSH_RETURN_OPTIONS); } @@ -724,11 +724,11 @@ TclCompileCatchCmd( * to happen after INST_END_CATCH (compile-3.6/7). */ - if (optsIndex != -1) { + if (optsIndex != TCL_INDEX_NONE) { OP4( STORE_SCALAR, optsIndex); OP( POP); } - if (resultIndex != -1) { + if (resultIndex != TCL_INDEX_NONE) { OP4( STORE_SCALAR, resultIndex); } OP( POP); @@ -1629,7 +1629,8 @@ CompileDictEachCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *varsTokenPtr, *dictTokenPtr, *bodyTokenPtr; - Tcl_LVTIndex keyVarIndex, valueVarIndex, infoIndex, collectVar = -1; + Tcl_LVTIndex keyVarIndex, valueVarIndex, infoIndex; + Tcl_LVTIndex collectVar = TCL_INDEX_NONE; Tcl_Size nameChars, numVars; Tcl_ExceptionRange loopRange, catchRange; Tcl_BytecodeLabel bodyTarget, emptyTarget, endTarget; @@ -2277,7 +2278,8 @@ IssueDictWithBodied( * Start by allocating local (unnamed, untraced) working variables. */ - Tcl_LVTIndex dictVar, varNameTmp = -1, pathTmp = -1, keysTmp; + Tcl_LVTIndex dictVar, keysTmp; + Tcl_LVTIndex varNameTmp = TCL_INDEX_NONE, pathTmp = TCL_INDEX_NONE; int gotPath; Tcl_Size i; Tcl_BytecodeLabel done; @@ -2292,7 +2294,7 @@ IssueDictWithBodied( gotPath = (numWords > 3); dictVar = LocalScalarFromToken(varTokenPtr, envPtr); - if (dictVar == -1) { + if (dictVar == TCL_INDEX_NONE) { varNameTmp = AnonymousLocal(envPtr); } if (gotPath) { @@ -2304,7 +2306,7 @@ IssueDictWithBodied( * Issue instructions. First, the part to expand the dictionary. */ - if (dictVar == -1) { + if (dictVar == TCL_INDEX_NONE) { PUSH_TOKEN( varTokenPtr, 1); OP4( STORE_SCALAR, varNameTmp); } @@ -2317,14 +2319,14 @@ IssueDictWithBodied( OP4( LIST, numWords - 3); OP4( STORE_SCALAR, pathTmp); OP( POP); - if (dictVar == -1) { + if (dictVar == TCL_INDEX_NONE) { OP( LOAD_STK); } else { OP4( LOAD_SCALAR, dictVar); } OP4( LOAD_SCALAR, pathTmp); } else { - if (dictVar == -1) { + if (dictVar == TCL_INDEX_NONE) { OP( LOAD_STK); } else { OP4( LOAD_SCALAR, dictVar); @@ -2350,7 +2352,7 @@ IssueDictWithBodied( * Now fold the results back into the dictionary in the OK case. */ - if (dictVar == -1) { + if (dictVar == TCL_INDEX_NONE) { OP4( LOAD_SCALAR, varNameTmp); if (gotPath) { OP4( LOAD_SCALAR, pathTmp); @@ -2379,7 +2381,7 @@ IssueDictWithBodied( OP( PUSH_RETURN_OPTIONS); OP( PUSH_RESULT); OP( END_CATCH); - if (dictVar == -1) { + if (dictVar == TCL_INDEX_NONE) { OP4( LOAD_SCALAR, varNameTmp); if (numWords > 3) { OP4( LOAD_SCALAR, pathTmp); @@ -2437,7 +2439,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; @@ -2461,10 +2464,9 @@ PrintDictUpdateInfo( Tcl_Size i; for (i=0 ; ilength ; 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]); } } @@ -2595,10 +2597,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, parsePtr->numWords-1, envPtr); + TclCompileExprWords(interp, firstWordPtr, parsePtr->numWords - 1, envPtr); return TCL_OK; } @@ -3124,11 +3126,11 @@ PrintForeachInfo( ForeachVarList *varsPtr; Tcl_Size i, j; - Tcl_AppendToObj(appendObj, "data=[", -1); + Tcl_AppendToObj(appendObj, "data=[", TCL_AUTO_LENGTH); for (i=0 ; inumLists ; i++) { if (i) { - Tcl_AppendToObj(appendObj, ", ", -1); + Tcl_AppendToObj(appendObj, ", ", TCL_AUTO_LENGTH); } Tcl_AppendPrintfToObj(appendObj, "%%v%" TCL_Z_MODIFIER "u", (infoPtr->firstValueTemp + i)); @@ -3137,19 +3139,19 @@ PrintForeachInfo( infoPtr->loopCtTemp); for (i=0 ; inumLists ; 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 ; jnumVars ; 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); } } @@ -3168,18 +3170,18 @@ PrintNewForeachInfo( infoPtr->loopCtTemp); for (i=0 ; inumLists ; 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 ; jnumVars ; 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); } } @@ -3320,7 +3322,8 @@ TclCompileFormatCmd( return TCL_ERROR; } - objv = (Tcl_Obj **)TclStackAlloc(interp, (numWords - 2) * sizeof(Tcl_Obj *)); + objv = (Tcl_Obj **)TclStackAlloc(interp, + (numWords - 2) * sizeof(Tcl_Obj *)); for (i=0 ; i+2 < numWords ; i++) { tokenPtr = TokenAfter(tokenPtr); TclNewObj(objv[i]); @@ -3498,7 +3501,7 @@ TclLocalScalarFromToken( TclPushVarName(NULL, tokenPtr, envPtr, TCL_NO_ELEMENT, &index, &isScalar); if (!isScalar) { - index = -1; + index = TCL_INDEX_NONE; } return index; } @@ -3554,7 +3557,7 @@ TclPushVarName( 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. */ + Tcl_Size *localIndexPtr, /* Must not be NULL. */ int *isScalarPtr) /* Must not be NULL. */ { const char *p; @@ -3575,7 +3578,7 @@ TclPushVarName( name = elName = NULL; nameLen = elNameLen = 0; - localIndex = -1; + localIndex = TCL_INDEX_NONE; if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { /* @@ -3587,11 +3590,11 @@ TclPushVarName( name = varTokenPtr[1].start; nameLen = varTokenPtr[1].size; - if (name[nameLen-1] == ')') { + if (name[nameLen - 1] == ')') { /* * last char is ')' => potential array reference. */ - last = &name[nameLen-1]; + last = &name[nameLen - 1]; if (*last == ')') { for (p = name; p < last; p++) { @@ -3677,8 +3680,8 @@ TclPushVarName( * Copy the remaining tokens. */ - memcpy(elemTokenPtr+1, varTokenPtr+2, - (n-1) * sizeof(Tcl_Token)); + memcpy(elemTokenPtr + 1, varTokenPtr + 2, + (n - 1) * sizeof(Tcl_Token)); } else { /* * Use the already available tokens. diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 986bb47..5562bf9 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -474,7 +474,7 @@ TclCompileIncrCmd( * Emit the instruction to increment the variable. */ - if (isScalar) { /* Simple scalar variable. */ + if (isScalar) { /* Simple scalar variable. */ if (localIndex >= 0) { if (haveImmValue) { OP41( INCR_SCALAR_IMM, localIndex, immValue); @@ -2243,7 +2243,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, @@ -2661,7 +2662,7 @@ IndexTailVarIfKnown( */ if (!EnvHasLVT(envPtr)) { - return -1; + return TCL_INDEX_NONE; } TclNewObj(tailPtr); @@ -2674,7 +2675,7 @@ IndexTailVarIfKnown( if (lastTokenPtr->type != TCL_TOKEN_TEXT) { Tcl_DecrRefCount(tailPtr); - return -1; + return TCL_INDEX_NONE; } Tcl_SetStringObj(tailPtr, lastTokenPtr->start, lastTokenPtr->size); } @@ -2688,14 +2689,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; @@ -2707,7 +2708,7 @@ IndexTailVarIfKnown( */ Tcl_DecrRefCount(tailPtr); - return -1; + return TCL_INDEX_NONE; } len -= p - tailName; tailName = p; diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 327c54a..898853d 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. @@ -38,8 +38,8 @@ 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 -1 for none. - Tcl_LVTIndex optionVar; // The option variable index, or -1 for none. + Tcl_LVTIndex resultVar; // The result variable index, or TCL_INDEX_NONE + Tcl_LVTIndex optionVar; // The option variable index, or TCL_INDEX_NONE } TryHandlerInfo; /* @@ -1178,7 +1178,7 @@ TclCompileStringReplaceCmd( if (last == (int)TCL_INDEX_END) { /* empty suffix too => empty result */ - OP( POP); /* Pop original */ + OP( POP); /* Pop original */ PUSH( ""); return TCL_OK; } @@ -1436,9 +1436,9 @@ TclCompileSubstCmd( 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])) { @@ -1456,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); @@ -1694,7 +1694,8 @@ TclSubstCompile( /* *---------------------------------------------------------------------- * - * HasDefaultClause, IsFallthroughToken, IsFallthroughArm, SetSwitchLineInformation -- + * HasDefaultClause, IsFallthroughToken, IsFallthroughArm, + * SetSwitchLineInformation -- * * Support utilities for [switch] compilation. * @@ -2111,8 +2112,6 @@ IssueSwitchChainedTests( int simple, exact; /* For extracting the type of regexp. */ Tcl_Size i, j; -#define NO_PENDING_JUMP -1 - /* * Generate a test for each arm. */ @@ -2371,7 +2370,7 @@ IssueSwitchJumpTable( * term. */ - if (i!=numArms-1 || !HasDefaultClause(numArms, arms)) { + 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, @@ -2555,9 +2554,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", @@ -2940,7 +2939,7 @@ TclCompileTryCmd( goto failedToCompile; } } else { - handlers[handlerIdx].resultVar = -1; + handlers[handlerIdx].resultVar = TCL_INDEX_NONE; } if (objc == 2) { Tcl_Size len; @@ -2952,7 +2951,7 @@ TclCompileTryCmd( goto failedToCompile; } } else { - handlers[handlerIdx].optionVar = -1; + handlers[handlerIdx].optionVar = TCL_INDEX_NONE; } Tcl_BounceRefCount(tmpObj); @@ -3053,8 +3052,8 @@ TclCompileTryCmd( *---------------------------------------------------------------------- * * IssueTryClausesInstructions, IssueTryTraplessClausesInstructions, - * IssueTryClausesFinallyInstructions, IssueTryTraplessClausesFinallyInstructions, - * IssueTryFinallyInstructions -- + * IssueTryClausesFinallyInstructions, IssueTryFinallyInstructions, + * IssueTryTraplessClausesFinallyInstructions -- * * The code generators for [try]. Split from the parsing engine for * reasons of developer sanity, and also split between no-finally, @@ -3146,7 +3145,7 @@ IssueTryClausesInstructions( continuationJumps = afterReturn0 + numHandlers; noError = continuationJumps + numHandlers; for (i=0; i= 0) { + if (handlers[i].resultVar != TCL_INDEX_NONE) { OP4( LOAD_SCALAR, resultVar); OP4( STORE_SCALAR, handlers[i].resultVar); OP( POP); } - if (handlers[i].optionVar >= 0) { + if (handlers[i].optionVar != TCL_INDEX_NONE) { OP4( LOAD_SCALAR, optionsVar); OP4( STORE_SCALAR, handlers[i].optionVar); OP( POP); @@ -3196,10 +3195,10 @@ IssueTryClausesInstructions( if (continuationsPending) { continuationsPending = 0; for (j=0 ; j= 0) { + if (handlers[i].resultVar != TCL_INDEX_NONE) { OP4( LOAD_SCALAR, resultVar); OP4( STORE_SCALAR, handlers[i].resultVar); OP( POP); } - if (handlers[i].optionVar >= 0) { + if (handlers[i].optionVar != TCL_INDEX_NONE) { OP4( LOAD_SCALAR, optionsVar); OP4( STORE_SCALAR, handlers[i].optionVar); OP( POP); @@ -3392,10 +3391,10 @@ IssueTryTraplessClausesInstructions( if (continuationsPending) { continuationsPending = 0; for (j=0 ; j= 0 || handlers[i].optionVar >= 0 + 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 >= 0 || handlers[i].optionVar >= 0) { - if (handlers[i].resultVar >= 0) { + 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 >= 0) { + if (handlers[i].optionVar != TCL_INDEX_NONE) { OP4( LOAD_SCALAR, optionsLocal); OP4( STORE_SCALAR, handlers[i].optionVar); OP( POP); @@ -3636,11 +3637,11 @@ IssueTryClausesFinallyInstructions( forwardsNeedFixing = 0; FWDJUMP( JUMP, bodyStart); for (j=0 ; j= 0 || handlers[i].optionVar >= 0 + 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 >= 0 || handlers[i].optionVar >= 0) { - if (handlers[i].resultVar >= 0) { + 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 >= 0) { + if (handlers[i].optionVar != TCL_INDEX_NONE) { OP4( LOAD_SCALAR, optionsLocal); OP4( STORE_SCALAR, handlers[i].optionVar); OP( POP); @@ -3919,11 +3922,11 @@ IssueTryTraplessClausesFinallyInstructions( forwardsNeedFixing = 0; FWDJUMP( JUMP, bodyStart); for (j=0 ; j", "<=", ">=" */ - 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*/ }; /* @@ -785,14 +785,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 +802,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"; @@ -1449,7 +1452,7 @@ ParseExpr( */ if (post != NULL) { - Tcl_AppendToObj(msg, ";\n", -1); + Tcl_AppendToObj(msg, ";\n", TCL_AUTO_LENGTH); Tcl_AppendObjToObj(msg, post); Tcl_DecrRefCount(post); } @@ -1856,10 +1859,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); @@ -2659,7 +2662,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; @@ -2670,29 +2674,30 @@ TclSortingOpCmd( nodes[0].lexeme = START; nodes[0].mark = MARK_RIGHT; for (i=2; itype == TCL_TOKEN_SIMPLE_WORD) \ - && ((tokenPtr)[1].size == LENGTH_OF(str)) \ - && strncmp((tokenPtr)[1].start, str, LENGTH_OF(str)) == 0) + && ((tokenPtr)[1].size == LENGTH_OF(str)) \ + && strncmp((tokenPtr)[1].start, str, LENGTH_OF(str)) == 0) #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) + && ((tokenPtr)[1].size >= (Tcl_Size)(minLength)) \ + && ((tokenPtr)[1].size <= LENGTH_OF(str)) \ + && strncmp((tokenPtr)[1].start, str, (tokenPtr)[1].size) == 0) #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) + && ((tokenPtr)[1].size > LENGTH_OF(str)) \ + && strncmp((tokenPtr)[1].start, str, LENGTH_OF(str)) == 0) #endif /* diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 31e3157..14fb433 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -63,7 +63,7 @@ static int traceInitialized = 0; */ InstructionDesc const tclInstructionTable[] = { - /* Name Bytes stackEffect Operand types */ + /* Name Bytes stackEffect Operand types */ TCL_INSTRUCTION_ENTRY( "done", -1), /* Finish ByteCode execution and return stktop (top stack item) */ @@ -969,9 +969,11 @@ 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); @@ -1076,7 +1078,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; } @@ -1273,7 +1276,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; @@ -1323,7 +1326,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; @@ -1661,7 +1664,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; @@ -2295,7 +2298,7 @@ TclClearFailedCompile( * Throw out any line information generated by the failed compile attempt. */ - while (lineInfoPtr->mapPtr->nuloc - 1 > lineInfoPtr->eclIndex) { + while (lineInfoPtr->mapPtr->nuloc - 1 > lineInfoPtr->eclIndex) { ECL *eclPtr = &lineInfoPtr->mapPtr->loc[--lineInfoPtr->mapPtr->nuloc]; Tcl_Free(eclPtr->line); eclPtr->line = NULL; @@ -2341,8 +2344,8 @@ 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'. */ @@ -2440,10 +2443,12 @@ TclCompileScript( * first null character. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { - Tcl_Size 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. */ Tcl_Size depth = TclGetStackDepth(envPtr); Interp *iPtr = (Interp *) interp; @@ -2460,7 +2465,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; @@ -2481,7 +2487,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; @@ -2584,7 +2590,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 @@ -2669,7 +2675,7 @@ TclCompileVarSubst( * of local variables in a procedure frame. */ - localVar = -1; + localVar = TCL_INDEX_NONE; if (localVarName != -1) { localVar = TclFindCompiledLocal(name, nameBytes, localVarName, envPtr); } @@ -3221,7 +3227,8 @@ 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", + Tcl_Panic("TclInitByteCodeObj: " + "encoded cmd location bytes %lu != expected size %lu", (unsigned long)(nextPtr - p), (unsigned long)cmdLocBytes); } #endif @@ -3376,7 +3383,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 { @@ -3490,7 +3498,8 @@ EnterCmdStartData( 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) { @@ -3506,7 +3515,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 @@ -3569,11 +3579,13 @@ EnterCmdExtentData( 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); } @@ -3627,7 +3639,7 @@ EnterCmdWordData( /* * 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; @@ -3828,8 +3840,8 @@ 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); @@ -3854,8 +3866,8 @@ 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] = @@ -4162,7 +4174,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 diff --git a/generic/tclCompile.h b/generic/tclCompile.h index a19c79b..cdfce6c 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -1107,7 +1107,8 @@ CreateJumptableEntry( Tcl_Size offset) { int isNew; - Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(&jtPtr->hashTable, keyPtr, &isNew); + Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(&jtPtr->hashTable, keyPtr, + &isNew); if (isNew) { Tcl_SetHashValue(hPtr, INT2PTR(offset)); } @@ -1859,7 +1860,8 @@ ExceptionRangeStarts( Tcl_Size offset; envPtr->exceptDepth++; - envPtr->maxExceptDepth = TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth); + envPtr->maxExceptDepth = TclMax(envPtr->exceptDepth, + envPtr->maxExceptDepth); offset = CurrentOffset(envPtr); envPtr->exceptArrayPtr[index].codeOffset = offset; return (int) offset; @@ -1939,8 +1941,11 @@ ExceptionRangeEnds( } while (0) #define PushVarNameWord(varTokenPtr,flags,localIndexPtr,isScalarPtr,wordIndex) \ - SetLineInformation(wordIndex); \ - TclPushVarName(interp,varTokenPtr,envPtr,flags,localIndexPtr,isScalarPtr) + do { \ + SetLineInformation(wordIndex); \ + TclPushVarName(interp, varTokenPtr, envPtr, flags, \ + localIndexPtr, isScalarPtr); \ + } while (0) #define ClearFailedCompile(envPtr) \ TclClearFailedCompile((envPtr), &lineInfo) diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index 60917f2..1b28ce6 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -281,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)); @@ -292,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, @@ -304,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, @@ -326,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) { @@ -357,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: @@ -448,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)); @@ -574,7 +592,8 @@ FormatInstruction( case OPERAND_UINT4: 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); @@ -587,9 +606,11 @@ FormatInstruction( case OPERAND_OFFSET4: 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; @@ -628,14 +649,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; @@ -1192,14 +1215,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)); -- cgit v0.12 From 165eb1f3e7a801816ad370d8844096274340b11c Mon Sep 17 00:00:00 2001 From: oehhar Date: Mon, 5 May 2025 14:47:52 +0000 Subject: Add to changes.md bug section: scan "long mantissa" %g [42d14c] --- changes.md | 1 + 1 file changed, 1 insertion(+) diff --git a/changes.md b/changes.md index 007e535..27f0fc0 100644 --- a/changes.md +++ b/changes.md @@ -23,6 +23,7 @@ to the userbase. - [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) # Incompatibilities - No known incompatibilities with the Tcl 9.0.0 public interface. -- cgit v0.12 From 1f531e65e38294c167aa6908ce02840958615b3b Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 5 May 2025 15:34:04 +0000 Subject: Merge tclCompUtils.h into tclCompile.h --- generic/tclCompCmds.c | 2 +- generic/tclCompCmdsGR.c | 2 +- generic/tclCompCmdsSZ.c | 2 +- generic/tclCompExpr.c | 10 ++-- generic/tclCompUtils.h | 138 ----------------------------------------------- generic/tclCompile.c | 96 ++++++++++++++++----------------- generic/tclCompile.h | 115 +++++++++++++++++++++++++++++++++++++++ generic/tclDisassemble.c | 6 ++- generic/tclEnsemble.c | 2 +- unix/Makefile.in | 7 ++- 10 files changed, 178 insertions(+), 202 deletions(-) delete mode 100644 generic/tclCompUtils.h diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 30887c4..5253cfb 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -14,7 +14,7 @@ */ #include "tclInt.h" -#include "tclCompUtils.h" +#include "tclCompile.h" #include /* diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 5562bf9..fb2a9e3 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -15,7 +15,7 @@ */ #include "tclInt.h" -#include "tclCompUtils.h" +#include "tclCompile.h" #include /* diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 898853d..c8d00a9 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -16,7 +16,7 @@ */ #include "tclInt.h" -#include "tclCompUtils.h" +#include "tclCompile.h" #include "tclStringTrim.h" /* diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 89ad7e3..59cb39a 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -2271,7 +2271,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); @@ -2370,7 +2370,7 @@ CompileExprTree( jumpPtr = newJump; TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpPtr->jump); - TclAdjustStackDepth(-1, envPtr); + STKDELTA(-1); if (convert) { jumpPtr->jump.jumpType = TCL_TRUE_JUMP; } @@ -2393,7 +2393,7 @@ CompileExprTree( case START: case QUESTION: if (convert && (nodePtr == rootPtr)) { - TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr); + OP( TRY_CVT_TO_NUMERIC); } break; case OPEN_PAREN: @@ -2449,7 +2449,7 @@ CompileExprTree( TclEmitPush(TclRegisterLiteral(envPtr, (nodePtr->lexeme == AND) ? "1" : "0", 1, 0), envPtr); TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &pc2); - TclAdjustStackDepth(-1, envPtr); + STKDELTA(-1); TclFixupForwardJumpToHere(envPtr, &pc1); TclFixupForwardJumpToHere(envPtr, &jumpPtr->jump); TclEmitPush(TclRegisterLiteral(envPtr, @@ -2518,7 +2518,7 @@ CompileExprTree( * that preserves internalreps. */ - TclEmitPush(TclAddLiteralObj(envPtr, literal, NULL), envPtr); + PUSH_OBJ( literal); } (*litObjvPtr)++; break; diff --git a/generic/tclCompUtils.h b/generic/tclCompUtils.h deleted file mode 100644 index f588499..0000000 --- a/generic/tclCompUtils.h +++ /dev/null @@ -1,138 +0,0 @@ -/* - * tclCompUtils.h -- - * - * This file contains utility macros for generating Tcl bytecode. - * - * Copyright (c) 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. - */ - -#ifndef _TCLCOMPUTILS -#define _TCLCOMPUTILS 1 - -#include "tclCompile.h" - -/* - * The type of "labels" used in FWDLABEL() and BACKLABEL(). - */ -typedef Tcl_Size Tcl_BytecodeLabel; - -/* - * The type of "catch ranges" used in CATCH_RANGE(), etc. - */ -typedef Tcl_Size Tcl_ExceptionRange; - -/* - * 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; - -/* - * Used to indicate that no jump is pending resolution. - */ -#define NO_PENDING_JUMP ((Tcl_Size) -1) - -/* - * 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) \ - TclEmitInstInt14(INST_##name,(val1),(val2),envPtr) -#define OP44(name,val1,val2) \ - TclEmitInstInt44(INST_##name,(val1),(val2),envPtr) -#define OP41(name,val1,val2) \ - TclEmitInstInt41(INST_##name,(val1),(val2),envPtr) - -#define PUSH(str) \ - PushStringLiteral(envPtr, str) -#define PUSH_STRING(strVar) \ - PushLiteral(envPtr, (strVar), TCL_AUTO_LENGTH) -#define PUSH_SIMPLE_TOKEN(tokenPtr) \ - PushLiteral(envPtr, (tokenPtr)[1].start, (tokenPtr)[1].size) -#define PUSH_OBJ(objPtr) \ - TclEmitPush(TclAddLiteralObj(envPtr, (objPtr), NULL), envPtr) -#define PUSH_TOKEN(tokenPtr, index) \ - CompileWord(envPtr, (tokenPtr), interp, (index)) -#define PUSH_EXPR_TOKEN(tokenPtr, index) \ - do { \ - SetLineInformation(index); \ - TclCompileExprWords(interp, (tokenPtr), 1, envPtr); \ - } while (0) -#define BODY(tokenPtr, index) \ - do { \ - SetLineInformation((index)); \ - TclCompileCmdWord(interp, \ - (tokenPtr)+1, (tokenPtr)->numComponents, \ - envPtr); \ - } while (0) - -#define BACKLABEL(var) \ - (var)=CurrentOffset(envPtr) -#define BACKJUMP(name, var) \ - TclEmitInstInt4(INST_##name,(var)-CurrentOffset(envPtr),envPtr) -#define FWDJUMP(name,var) \ - (var)=CurrentOffset(envPtr);TclEmitInstInt4(INST_##name,0,envPtr) -#define FWDLABEL(var) \ - TclStoreInt4AtPtr(CurrentOffset(envPtr)-(var),envPtr->codeStart+(var)+1) -#define INVOKE(name) \ - TclEmitInvoke(envPtr,INST_##name) - -#define MAKE_CATCH_RANGE() \ - TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr) -#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)) -#define CATCH_RANGE(range) \ - CATCH_RANGE_VAR((range), JOIN(catchRange_, __LINE__)) -#define CATCH_TARGET(range) \ - ExceptionRangeTarget(envPtr, (range), catchOffset) -#define BREAK_TARGET(range) \ - ExceptionRangeTarget(envPtr, (range), breakOffset) -#define CONTINUE_TARGET(range) \ - ExceptionRangeTarget(envPtr, (range), continueOffset) -#define FINALIZE_LOOP(range) \ - TclFinalizeLoopExceptionRange(envPtr, (range)) - -#define STKDELTA(delta) \ - TclAdjustStackDepth((delta), envPtr) - -#define TokenToObj(tokenPtr) \ - Tcl_NewStringObj((tokenPtr)[1].start, (tokenPtr)[1].size) -#define LENGTH_OF(str) \ - ((Tcl_Size) sizeof(str "") - 1) -#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) -#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) -#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) -#endif - -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * End: - */ diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 14fb433..14d4b25 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -2183,8 +2183,7 @@ 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; } @@ -2245,7 +2244,7 @@ CompileCmdCompileProc( case 0: unwind = tclInstructionTable[INST_START_CMD].numBytes; incrOffset = CurrentOffset(envPtr) + 5; - TclEmitInstInt44( INST_START_CMD, 0, 0, envPtr); + OP44( START_CMD, 0, 0); break; case 1: if (envPtr->codeNext > envPtr->codeStart) { @@ -2411,7 +2410,7 @@ CompileCommandTokens( Tcl_DecrRefCount(cmdObj); - TclEmitOpcode( INST_POP, envPtr); + OP( POP); EnterCmdExtentData(envPtr, cmdIdx, parsePtr->term - parsePtr->commandStart, CurrentOffset(envPtr) - startCodeOffset); @@ -2598,7 +2597,7 @@ TclCompileScript( * simple bytecode that makes that happen. */ - PushStringLiteral(envPtr, ""); + PUSH( ""); } else { /* * We compiled at least one command to bytecode. The routine @@ -2692,16 +2691,16 @@ TclCompileVarSubst( if (tokenPtr->numComponents == 1) { if (localVar < 0) { - TclEmitOpcode( INST_LOAD_STK, envPtr); + OP( LOAD_STK); } else { - TclEmitInstInt4( INST_LOAD_SCALAR, localVar, envPtr); + OP4( LOAD_SCALAR, localVar); } } else { TclCompileTokens(interp, tokenPtr+2, tokenPtr->numComponents-1, envPtr); if (localVar < 0) { - TclEmitOpcode( INST_LOAD_ARRAY_STK, envPtr); + OP( LOAD_ARRAY_STK); } else { - TclEmitInstInt4( INST_LOAD_ARRAY, localVar, envPtr); + OP4( LOAD_ARRAY, localVar); } } } @@ -2876,11 +2875,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); } /* @@ -2888,7 +2887,7 @@ TclCompileTokens( */ if (envPtr->codeNext == entryCodeNext) { - PushStringLiteral(envPtr, ""); + PUSH( ""); } Tcl_DStringFree(&textBuffer); @@ -3005,19 +3004,19 @@ TclCompileExprWords( for (i = 0; i < numWords; i++) { CompileTokens(envPtr, wordPtr, interp); if (i + 1 < numWords) { - PushStringLiteral(envPtr, " "); + 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); } /* @@ -3055,10 +3054,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; } @@ -3845,7 +3844,7 @@ TclAddLoopBreakFixup( } } auxPtr->breakTargets[auxPtr->numBreakTargets - 1] = CurrentOffset(envPtr); - TclEmitInstInt4( INST_JUMP, 0, envPtr); + OP4( JUMP, 0); } void @@ -3872,7 +3871,7 @@ TclAddLoopContinueFixup( } auxPtr->continueTargets[auxPtr->numContinueTargets - 1] = CurrentOffset(envPtr); - TclEmitInstInt4( INST_JUMP, 0, envPtr); + OP4( JUMP, 0); } /* @@ -3897,15 +3896,14 @@ TclCleanupStackForBreakContinue( if (toPop > 0) { while (toPop --> 0) { - TclEmitOpcode( INST_EXPAND_DROP, envPtr); + OP( EXPAND_DROP); } - TclAdjustStackDepth((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; } @@ -3928,7 +3926,7 @@ StartExpanding( { Tcl_Size i; - TclEmitOpcode( INST_EXPAND_START, envPtr); + OP( EXPAND_START); /* * Update inner exception ranges with information about the environment @@ -4263,13 +4261,13 @@ TclEmitForwardJump( switch (jumpType) { case TCL_UNCONDITIONAL_JUMP: - TclEmitInstInt4( INST_JUMP, 0, envPtr); + OP4( JUMP, 0); break; case TCL_TRUE_JUMP: - TclEmitInstInt4( INST_JUMP_TRUE, 0, envPtr); + OP4( JUMP_TRUE, 0); break; default: // TCL_FALSE_JUMP - TclEmitInstInt4( INST_JUMP_FALSE, 0, envPtr); + OP4( JUMP_FALSE, 0); break; } } @@ -4429,7 +4427,7 @@ TclEmitInvoke( } if (auxBreakPtr != NULL || auxContinuePtr != NULL) { - loopRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); + loopRange = MAKE_LOOP_RANGE(); ExceptionRangeStarts(envPtr, loopRange); } @@ -4440,45 +4438,45 @@ TclEmitInvoke( switch (opcode) { #ifndef TCL_NO_DEPRECATED case INST_INVOKE_STK1: - TclEmitInstInt1( INST_INVOKE_STK1, arg1, envPtr); + OP1( INVOKE_STK1, arg1); break; #endif case INST_INVOKE_STK: - TclEmitInstInt4( INST_INVOKE_STK, arg1, envPtr); + 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: - TclEmitInstInt41( INST_INVOKE_REPLACE, arg1, arg2, envPtr); + OP41( INVOKE_REPLACE, arg1, arg2); break; #ifndef TCL_NO_DEPRECATED case INST_TCLOO_NEXT1: - TclEmitInstInt1( INST_TCLOO_NEXT1, arg1, envPtr); + OP1( TCLOO_NEXT1, arg1); break; case INST_TCLOO_NEXT_CLASS1: - TclEmitInstInt1( INST_TCLOO_NEXT_CLASS1, arg1, envPtr); + OP1( TCLOO_NEXT_CLASS1, arg1); break; #endif case INST_TCLOO_NEXT: - TclEmitInstInt4( INST_TCLOO_NEXT, arg1, envPtr); + OP4( TCLOO_NEXT, arg1); break; case INST_TCLOO_NEXT_CLASS: - TclEmitInstInt4( INST_TCLOO_NEXT_CLASS, arg1, envPtr); + OP4( TCLOO_NEXT_CLASS, arg1); break; case INST_YIELD: - TclEmitOpcode( INST_YIELD, envPtr); + OP( YIELD); break; case INST_YIELD_TO_INVOKE: - TclEmitOpcode( INST_YIELD_TO_INVOKE, envPtr); + OP( YIELD_TO_INVOKE); break; default: Tcl_Panic("opcode %s not handled by TclEmitInvoke()", @@ -4512,30 +4510,30 @@ 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); + FINALIZE_LOOP( loopRange); TclFixupForwardJumpToHere(envPtr, &nonTrapFixup); } TclCheckStackDepth(depth+1-cleanup, envPtr); diff --git a/generic/tclCompile.h b/generic/tclCompile.h index cdfce6c..7ea6688 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 + * Copyright (c) 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. @@ -2002,6 +2003,120 @@ RegisterJumptableNum( } /* + * The type of "labels" used in FWDLABEL() and BACKLABEL(). + */ +typedef Tcl_Size Tcl_BytecodeLabel; + +/* + * The type of "catch ranges" used in CATCH_RANGE(), etc. + */ +typedef Tcl_Size Tcl_ExceptionRange; + +/* + * 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; + +/* + * Used to indicate that no jump is pending resolution. + */ +#define NO_PENDING_JUMP ((Tcl_Size) -1) + +/* + * 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) \ + TclEmitInstInt14(INST_##name,(val1),(val2),envPtr) +#define OP44(name,val1,val2) \ + TclEmitInstInt44(INST_##name,(val1),(val2),envPtr) +#define OP41(name,val1,val2) \ + TclEmitInstInt41(INST_##name,(val1),(val2),envPtr) + +#define PUSH(str) \ + PushStringLiteral(envPtr, str) +#define PUSH_STRING(strVar) \ + PushLiteral(envPtr, (strVar), TCL_AUTO_LENGTH) +#define PUSH_SIMPLE_TOKEN(tokenPtr) \ + PushLiteral(envPtr, (tokenPtr)[1].start, (tokenPtr)[1].size) +#define PUSH_OBJ(objPtr) \ + TclEmitPush(TclAddLiteralObj(envPtr, (objPtr), NULL), envPtr) +#define PUSH_TOKEN(tokenPtr, index) \ + CompileWord(envPtr, (tokenPtr), interp, (index)) +#define PUSH_EXPR_TOKEN(tokenPtr, index) \ + do { \ + SetLineInformation(index); \ + TclCompileExprWords(interp, (tokenPtr), 1, envPtr); \ + } while (0) +#define BODY(tokenPtr, index) \ + do { \ + SetLineInformation((index)); \ + TclCompileCmdWord(interp, \ + (tokenPtr)+1, (tokenPtr)->numComponents, \ + envPtr); \ + } while (0) + +#define BACKLABEL(var) \ + (var)=CurrentOffset(envPtr) +#define BACKJUMP(name, var) \ + TclEmitInstInt4(INST_##name,(var)-CurrentOffset(envPtr),envPtr) +#define FWDJUMP(name,var) \ + (var)=CurrentOffset(envPtr);TclEmitInstInt4(INST_##name,0,envPtr) +#define FWDLABEL(var) \ + TclStoreInt4AtPtr(CurrentOffset(envPtr)-(var),envPtr->codeStart+(var)+1) +#define INVOKE(name) \ + TclEmitInvoke(envPtr,INST_##name) + +#define MAKE_CATCH_RANGE() \ + TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr) +#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)) +#define CATCH_RANGE(range) \ + CATCH_RANGE_VAR((range), JOIN(catchRange_, __LINE__)) +#define CATCH_TARGET(range) \ + ExceptionRangeTarget(envPtr, (range), catchOffset) +#define BREAK_TARGET(range) \ + ExceptionRangeTarget(envPtr, (range), breakOffset) +#define CONTINUE_TARGET(range) \ + ExceptionRangeTarget(envPtr, (range), continueOffset) +#define FINALIZE_LOOP(range) \ + TclFinalizeLoopExceptionRange(envPtr, (range)) + +#define STKDELTA(delta) \ + TclAdjustStackDepth((delta), envPtr) + +#define TokenToObj(tokenPtr) \ + Tcl_NewStringObj((tokenPtr)[1].start, (tokenPtr)[1].size) +#define LENGTH_OF(str) \ + ((Tcl_Size) sizeof(str "") - 1) +#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) +#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) +#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/tclDisassemble.c b/generic/tclDisassemble.c index 1b28ce6..c9b9761 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -811,12 +811,14 @@ TclGetInnerContext( break; case INST_INVOKE_STK: - objc = TclGetUInt4AtPtr(pc+1); + 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; diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index f5dcd6c..c1d8613 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -11,7 +11,7 @@ */ #include "tclInt.h" -#include "tclCompUtils.h" +#include "tclCompile.h" /* * Declarations for functions local to this file: diff --git a/unix/Makefile.in b/unix/Makefile.in index 0a38601..8377612 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -1253,7 +1253,6 @@ REGHDRS = $(GENERIC_DIR)/regex.h $(GENERIC_DIR)/regguts.h \ $(GENERIC_DIR)/regcustom.h TCLREHDRS = $(GENERIC_DIR)/tclRegexp.h COMPILEHDR = $(GENERIC_DIR)/tclCompile.h -COMPUTILHDR = $(GENERIC_DIR)/tclCompUtils.h FSHDR = $(GENERIC_DIR)/tclFileSystem.h IOHDR = $(GENERIC_DIR)/tclIO.h MATHHDRS = $(GENERIC_DIR)/tclTomMath.h $(GENERIC_DIR)/tclTomMathDecls.h @@ -1321,13 +1320,13 @@ tclCmdMZ.o: $(GENERIC_DIR)/tclCmdMZ.c $(TCLREHDRS) $(TRIMHDR) tclDate.o: $(GENERIC_DIR)/tclDate.c $(TCLDATEHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclDate.c -tclCompCmds.o: $(GENERIC_DIR)/tclCompCmds.c $(COMPILEHDR) $(COMPUTILHDR) +tclCompCmds.o: $(GENERIC_DIR)/tclCompCmds.c $(COMPILEHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCompCmds.c -tclCompCmdsGR.o: $(GENERIC_DIR)/tclCompCmdsGR.c $(COMPILEHDR) $(COMPUTILHDR) +tclCompCmdsGR.o: $(GENERIC_DIR)/tclCompCmdsGR.c $(COMPILEHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCompCmdsGR.c -tclCompCmdsSZ.o: $(GENERIC_DIR)/tclCompCmdsSZ.c $(COMPILEHDR) $(COMPUTILHDR) $(TRIMHDR) +tclCompCmdsSZ.o: $(GENERIC_DIR)/tclCompCmdsSZ.c $(COMPILEHDR) $(TRIMHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclCompCmdsSZ.c tclCompExpr.o: $(GENERIC_DIR)/tclCompExpr.c $(COMPILEHDR) -- cgit v0.12 From a0ecb0cc3cd831eadbd8753d617e79524892a73e Mon Sep 17 00:00:00 2001 From: oehhar Date: Mon, 5 May 2025 16:27:48 +0000 Subject: [78f44214] Document Tcl_InitStringRep: copy description from TIP 445: better than nothing... --- doc/ObjectType.3 | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/doc/ObjectType.3 b/doc/ObjectType.3 index ca9e0ce..688a04a 100644 --- a/doc/ObjectType.3 +++ b/doc/ObjectType.3 @@ -128,6 +128,17 @@ When \fInumBytes\fR is greater than zero, and the returned pointer is representation. The caller may then choose whether to raise an error or panic. .PP +\fBTcl_InitStringRep\fR performs the function of the existing internal macro +\fBTclInitStringRep\fR, but is extended to return a pointer to the string rep, +and to accept \fBNULL\fR as a value for bytes. +When \fIbytes\fR is \fBNULL\fR and \fIobjPtr\fR has no string rep, an uninitialzed +buffer of numBytes bytes is created for filling by the caller. +When \fIbytes\fR is \fBNULL\fR and \fIobjPtr\fR has a string rep, the string +rep will be truncated to a length of numBytes bytes. +When numBytes is greater than zero, and the returned pointer is \fBNULL\fR, that +indicates a failure to allocate memory for the string representation. +The caller may then choose whether to raise an error or panic. +.PP \fBTcl_HasStringRep\fR returns a boolean indicating whether or not a string rep is currently stored in \fIobjPtr\fR. This is used when the caller wants to act on \fIobjPtr\fR differently -- cgit v0.12 From d8892d524c1f79352760a33ca755d12e0fbb7a80 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 5 May 2025 19:40:29 +0000 Subject: Test of [testmsb] checking upper range boundary. --- tests/brodnik.test | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/tests/brodnik.test b/tests/brodnik.test index 281a3c9..a74f871 100644 --- a/tests/brodnik.test +++ b/tests/brodnik.test @@ -61,6 +61,11 @@ namespace eval ::tcl::test::brodnik { incr i } + # Test out-of-range rejection + test brodnik-3.0 {TclMSB correctness} -constraints testmsb -body { + testmsb [expr 1<<64] + } -returnCodes error -match glob -result * + cleanupTests } namespace delete ::tcl::test::brodnik -- cgit v0.12 From 9b753ab59fec6a67da308cebfa086c5ea138b3b8 Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 5 May 2025 20:14:45 +0000 Subject: Preparing to be able to disable the opcodes at some later date; we do not want to alter the opcode numbers when we do --- generic/tclCompile.c | 1 + generic/tclCompile.h | 61 ++++++++++++++++++++++++++++------------------------ 2 files changed, 34 insertions(+), 28 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 14d4b25..f9ad5ad 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -43,6 +43,7 @@ static int traceInitialized = 0; #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) \ diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 7ea6688..7c325ce 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -564,9 +564,14 @@ typedef struct ByteCode { * 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 ALLOW_DEPRECATED_OPCODES +#ifdef REMOVE_DEPRECATED_OPCODES +#define DEPRECATED_OPCODE(name) JOIN(INST_DEPRECATED_, __LINE__) +#elif defined(ALLOW_DEPRECATED_OPCODES) #define DEPRECATED_OPCODE(name) \ name #elif defined(_MSC_VER) @@ -592,52 +597,52 @@ enum TclInstruction { /* Opcodes 0 to 9 */ INST_DONE = 0, DEPRECATED_OPCODE(INST_PUSH1), - INST_PUSH, + INST_PUSH = 2, INST_POP, INST_DUP, INST_STR_CONCAT1, DEPRECATED_OPCODE(INST_INVOKE_STK1), - INST_INVOKE_STK, + INST_INVOKE_STK = 7, INST_EVAL_STK, INST_EXPR_STK, /* Opcodes 10 to 23 */ DEPRECATED_OPCODE(INST_LOAD_SCALAR1), - INST_LOAD_SCALAR, + INST_LOAD_SCALAR = 11, DEPRECATED_OPCODE(INST_LOAD_SCALAR_STK), // Not used DEPRECATED_OPCODE(INST_LOAD_ARRAY1), - INST_LOAD_ARRAY, + INST_LOAD_ARRAY = 14, INST_LOAD_ARRAY_STK, INST_LOAD_STK, DEPRECATED_OPCODE(INST_STORE_SCALAR1), - INST_STORE_SCALAR, + INST_STORE_SCALAR = 18, DEPRECATED_OPCODE(INST_STORE_SCALAR_STK), // Not used DEPRECATED_OPCODE(INST_STORE_ARRAY1), - INST_STORE_ARRAY, + INST_STORE_ARRAY = 21, INST_STORE_ARRAY_STK, INST_STORE_STK, /* Opcodes 24 to 33 */ DEPRECATED_OPCODE(INST_INCR_SCALAR1), - INST_INCR_SCALAR_STK, + INST_INCR_SCALAR_STK = 25, DEPRECATED_OPCODE(INST_INCR_ARRAY1), - INST_INCR_ARRAY_STK, + INST_INCR_ARRAY_STK = 27, INST_INCR_STK, DEPRECATED_OPCODE(INST_INCR_SCALAR1_IMM), - INST_INCR_SCALAR_STK_IMM, + INST_INCR_SCALAR_STK_IMM = 30, DEPRECATED_OPCODE(INST_INCR_ARRAY1_IMM), - INST_INCR_ARRAY_STK_IMM, + INST_INCR_ARRAY_STK_IMM = 32, INST_INCR_STK_IMM, /* Opcodes 34 to 39 */ DEPRECATED_OPCODE(INST_JUMP1), - INST_JUMP, + INST_JUMP = 35, DEPRECATED_OPCODE(INST_JUMP_TRUE1), - INST_JUMP_TRUE, + INST_JUMP_TRUE = 37, DEPRECATED_OPCODE(INST_JUMP_FALSE1), - INST_JUMP_FALSE, + INST_JUMP_FALSE = 39, - /* Opcodes 42 to 64 */ + /* Opcodes 42 to 60 */ INST_BITOR, INST_BITXOR, INST_BITAND, @@ -660,17 +665,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 */ + /* 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, @@ -678,24 +683,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 */ + /* Opcodes 76 to 81 */ DEPRECATED_OPCODE(INST_APPEND_SCALAR1), - INST_APPEND_SCALAR, + INST_APPEND_SCALAR = 77, DEPRECATED_OPCODE(INST_APPEND_ARRAY1), - INST_APPEND_ARRAY, + INST_APPEND_ARRAY = 79, INST_APPEND_ARRAY_STK, INST_APPEND_STK, - /* Opcodes 88 to 93 */ + /* Opcodes 82 to 87 */ DEPRECATED_OPCODE(INST_LAPPEND_SCALAR1), - INST_LAPPEND_SCALAR, + INST_LAPPEND_SCALAR = 83, DEPRECATED_OPCODE(INST_LAPPEND_ARRAY1), - INST_LAPPEND_ARRAY, + INST_LAPPEND_ARRAY = 85, INST_LAPPEND_ARRAY_STK, INST_LAPPEND_STK, @@ -781,7 +786,7 @@ enum TclInstruction { 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, @@ -806,7 +811,7 @@ enum TclInstruction { 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, @@ -852,7 +857,7 @@ enum TclInstruction { 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, -- cgit v0.12 From 218a91458aabb963b41181fae04b95cac5d8641a Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Tue, 6 May 2025 07:54:14 +0000 Subject: Update changes.md for fixed lseq tickets --- changes.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/changes.md b/changes.md index 04e0b2c..a4be411 100644 --- a/changes.md +++ b/changes.md @@ -25,6 +25,8 @@ to the userbase. - [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) # Incompatibilities - No known incompatibilities with the Tcl 9.0.0 public interface. -- cgit v0.12 From adb1650aa30981743e3d79d882b60d07395e48dd Mon Sep 17 00:00:00 2001 From: sbron Date: Tue, 6 May 2025 08:46:45 +0000 Subject: Fix links to tickets. --- changes.md | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/changes.md b/changes.md index a4be411..503725c 100644 --- a/changes.md +++ b/changes.md @@ -11,8 +11,8 @@ to the userbase. # 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/98006f) - - [tcl::mathfunc::isunordered inconsistency with some integer values](https://core.tcl-lang.org/tcl/tktview/67d5f7) + - [\[$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) -- cgit v0.12 From 349112862eb62de271c5a2964477c1e3ff8c19af Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 6 May 2025 13:41:29 +0000 Subject: Fix comment indentation --- generic/tclLiteral.c | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/generic/tclLiteral.c b/generic/tclLiteral.c index 563fa4c..0743336 100644 --- a/generic/tclLiteral.c +++ b/generic/tclLiteral.c @@ -506,7 +506,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. */ { @@ -552,7 +552,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. */ @@ -669,7 +669,7 @@ 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. */ size_t localHash) /* Hash value for the literal's string. */ @@ -748,7 +748,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. */ { /* @@ -830,7 +830,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. */ { -- cgit v0.12 From 9c7449fb49496cf68c0eef7452e0ad2bb3fac931 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 8 May 2025 15:19:32 +0000 Subject: Fix [9dcdddeefe]: compiler warnings. No need to put this in changelog, since it's introduced after 9.0.1. --- generic/tclStrToD.c | 20 ++++++++++++++------ 1 file changed, 14 insertions(+), 6 deletions(-) diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index ffbeb0c..d4843e7 100644 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -40,7 +40,7 @@ * Rounding controls. (Thanks a lot, Intel!) */ -#ifdef __i386 +#if defined(i386) || defined(__i386__) || defined(__i386) || defined(_M_IX86) /* * gcc on x86 needs access to rounding controls, because of a questionable * feature where it retains intermediate results as IEEE 'long double' values @@ -1252,7 +1252,7 @@ TclParseNumber( } } if (endPtrPtr == NULL) { - if ((len != 0) && ((numBytes + 1 > 1) || (*p != '\0'))) { + if ((len != 0) && ((numBytes > 0) || (*p != '\0'))) { status = TCL_ERROR; } } else { @@ -1879,22 +1879,30 @@ MakeHighPrecisionDouble( if (exponent < -511) { - mp_init_copy(&bntmp, significand); + if (mp_init_copy(&bntmp, significand) != MP_OKAY) { + Tcl_Panic("initialization failure in MakeHighPrecisionDouble"); + } shift = -exponent - 511; exponent += shift; while (shift > 0) { n = (shift > 9) ? 9 : shift; - mp_div_d(&bntmp, (mp_digit) pow10_wide[n], &bntmp, NULL); + if (mp_div_d(&bntmp, (mp_digit) pow10_wide[n], &bntmp, NULL) != MP_OKAY) { + Tcl_Panic("initialization failure in MakeHighPrecisionDouble"); + } shift -= n; } significand = &bntmp; } else if (exponent > 511) { - mp_init_copy(&bntmp, significand); + if (mp_init_copy(&bntmp, significand) != MP_OKAY) { + Tcl_Panic("initialization failure in MakeHighPrecisionDouble"); + } shift = exponent - 511; exponent -= shift; while (shift > 0) { n = (shift > 9) ? 9 : shift; - mp_mul_d(&bntmp, (mp_digit) pow10_wide[n], &bntmp); + if (mp_mul_d(&bntmp, (mp_digit) pow10_wide[n], &bntmp) != MP_OKAY) { + Tcl_Panic("initialization failure in MakeHighPrecisionDouble"); + } shift -= n; } significand = &bntmp; -- cgit v0.12 From 455497137dac85db23044e0d38ddfb9fd2842b45 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 9 May 2025 12:09:57 +0000 Subject: Final set of changes --- generic/tclCompCmdsGR.c | 12 +-- generic/tclCompCmdsSZ.c | 10 +-- generic/tclCompExpr.c | 41 ++++----- generic/tclCompile.c | 60 +++++-------- generic/tclCompile.h | 226 ++++++++++++++++++++++++++++-------------------- generic/tclEnsemble.c | 15 +--- generic/tclExecute.c | 3 +- generic/tclLiteral.c | 42 +++++++++ 8 files changed, 230 insertions(+), 179 deletions(-) diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index fb2a9e3..4237b32 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -2319,10 +2319,10 @@ TclCompileReturnCmd( 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; } @@ -2425,7 +2425,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); @@ -2750,7 +2750,7 @@ TclCompileObjectNextCmd( PUSH_TOKEN( tokenPtr, i); tokenPtr = TokenAfter(tokenPtr); } - TclEmitInvoke(envPtr, INST_TCLOO_NEXT, i); + INVOKE4( TCLOO_NEXT, i); return TCL_OK; } @@ -2775,7 +2775,7 @@ TclCompileObjectNextToCmd( PUSH_TOKEN( tokenPtr, i); tokenPtr = TokenAfter(tokenPtr); } - TclEmitInvoke(envPtr, INST_TCLOO_NEXT_CLASS, i); + INVOKE4( TCLOO_NEXT_CLASS, i); return TCL_OK; } diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index c8d00a9..1f51e2f 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -1520,7 +1520,6 @@ TclSubstCompile( for (endTokenPtr = tokenPtr + parse.numTokens; tokenPtr < endTokenPtr; tokenPtr = TokenAfter(tokenPtr)) { Tcl_Size length; - int literal; Tcl_ExceptionRange catchRange; Tcl_BytecodeLabel end, haveOk, haveOther, tableBase; JumptableNumInfo *retCodeTable; @@ -1529,9 +1528,7 @@ TclSubstCompile( 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++; @@ -1539,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: @@ -2694,6 +2690,7 @@ TclCompileTailcallCmd( DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr = parsePtr->tokenPtr; Tcl_Size i, numWords = parsePtr->numWords; + /* TODO: Consider support for compiling expanded args. */ if (numWords < 2 || numWords > UINT_MAX || envPtr->procPtr == NULL) { return TCL_ERROR; @@ -2702,6 +2699,7 @@ TclCompileTailcallCmd( OP( NS_CURRENT); for (i=1 ; ilexeme) { case FUNCTION: { - Tcl_DString cmdName; + Tcl_Obj *cmdName; - Tcl_DStringInit(&cmdName); - TclDStringAppendLiteral(&cmdName, "tcl::mathfunc::"); - TclDStringAppendObj(&cmdName, *funcObjv); + TclNewLiteralStringObj(cmdName, "tcl::mathfunc::"); + Tcl_AppendObjToObj(cmdName, *funcObjv); funcObjv++; - 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 @@ -2387,7 +2383,7 @@ CompileExprTree( } } else { Tcl_Size target; - JumpFixup pc1, pc2; + Tcl_BytecodeLabel pc1, pc2; switch (nodePtr->lexeme) { case START: @@ -2406,7 +2402,7 @@ CompileExprTree( * command with the correct number of arguments. */ - TclEmitInvoke(envPtr, INST_INVOKE_STK, numWords); + INVOKE4( INVOKE_STK, numWords); /* * Restore any saved numWords value. @@ -2443,18 +2439,18 @@ CompileExprTree( case AND: case OR: CLANG_ASSERT(jumpPtr); - TclEmitForwardJump(envPtr, - (nodePtr->lexeme == AND) ? TCL_FALSE_JUMP - : TCL_TRUE_JUMP, &pc1); - TclEmitPush(TclRegisterLiteral(envPtr, - (nodePtr->lexeme == AND) ? "1" : "0", 1, 0), envPtr); - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &pc2); + if (nodePtr->lexeme == AND) { + FWDJUMP( JUMP_FALSE, pc1); + } else { + FWDJUMP( JUMP_TRUE, pc1); + } + PUSH_STRING( (nodePtr->lexeme == AND) ? "1" : "0"); + FWDJUMP( JUMP, pc2); STKDELTA(-1); - TclFixupForwardJumpToHere(envPtr, &pc1); + FWDLABEL(pc1); TclFixupForwardJumpToHere(envPtr, &jumpPtr->jump); - TclEmitPush(TclRegisterLiteral(envPtr, - (nodePtr->lexeme == AND) ? "0" : "1", 1, 0), envPtr); - TclFixupForwardJumpToHere(envPtr, &pc2); + PUSH_STRING( (nodePtr->lexeme == AND) ? "0" : "1"); + FWDLABEL(pc2); convert = 0; freePtr = jumpPtr; jumpPtr = jumpPtr->next; @@ -2484,9 +2480,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)) { @@ -2507,7 +2501,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 diff --git a/generic/tclCompile.c b/generic/tclCompile.c index f9ad5ad..a79da62 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -2097,23 +2097,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 @@ -2144,16 +2139,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); } - TclEmitInvoke(envPtr, INST_INVOKE_STK, wordIdx); + INVOKE4( INVOKE_STK, wordIdx); TclCheckStackDepth(depth+1, envPtr); } @@ -2189,13 +2182,11 @@ CompileExpanded( 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); } /* @@ -2212,7 +2203,7 @@ CompileExpanded( * prepared and run, INST_EXPAND_STKTOP is not stack-neutral in general. */ - TclEmitInvoke(envPtr, INST_INVOKE_EXPANDED, wordIdx); + INVOKE4( INVOKE_EXPANDED, wordIdx); TclCheckStackDepth(depth + 1, envPtr); } @@ -2809,12 +2800,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); @@ -2835,10 +2824,7 @@ TclCompileTokens( */ if (Tcl_DStringLength(&textBuffer) > 0) { - int literal; - - literal = TclRegisterDStringLiteral(envPtr, &textBuffer); - TclEmitPush(literal, envPtr); + TclPushDString(envPtr, &textBuffer); numObjsToConcat++; Tcl_DStringFree(&textBuffer); } @@ -2860,9 +2846,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), @@ -2949,7 +2934,7 @@ TclCompileCmdWord( */ TclCompileTokens(interp, tokenPtr, count, envPtr); - TclEmitInvoke(envPtr, INST_EVAL_STK); + INVOKE( EVAL_STK); } } @@ -3311,7 +3296,7 @@ TclInitByteCodeObj( *---------------------------------------------------------------------- */ -Tcl_Size +Tcl_LVTIndex TclFindCompiledLocal( const char *name, /* Points to first character of the name of a * scalar or array variable. If NULL, a @@ -3698,7 +3683,7 @@ EnterCmdWordData( *---------------------------------------------------------------------- */ -Tcl_Size +Tcl_ExceptionRange TclCreateExceptRange( ExceptionRangeType type, /* The kind of ExceptionRange desired. */ CompileEnv *envPtr) /* Points to CompileEnv for which to create a @@ -3723,10 +3708,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 @@ -3982,7 +3967,7 @@ StartExpanding( void TclFinalizeLoopExceptionRange( CompileEnv *envPtr, - Tcl_Size range) + Tcl_ExceptionRange range) { ExceptionRange *rangePtr = &envPtr->exceptArrayPtr[range]; ExceptionAux *auxPtr = &envPtr->exceptAuxArrayPtr[range]; @@ -4058,7 +4043,7 @@ TclFinalizeLoopExceptionRange( *---------------------------------------------------------------------- */ -Tcl_Size +Tcl_AuxDataRef TclCreateAuxData( void *clientData, /* The compilation auxiliary data to store in * the new aux data record. */ @@ -4068,8 +4053,7 @@ TclCreateAuxData( * 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) { @@ -4347,7 +4331,7 @@ TclEmitInvoke( ExceptionRange *rangePtr; ExceptionAux *auxBreakPtr, *auxContinuePtr; Tcl_Size arg1, arg2, wordCount = 0, expandCount = 0; - Tcl_Size loopRange = 0, breakRange = 0, continueRange = 0; + Tcl_ExceptionRange loopRange = 0, breakRange = 0, continueRange = 0; Tcl_Size cleanup, depth = TclGetStackDepth(envPtr); /* @@ -4492,7 +4476,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; @@ -4502,7 +4486,7 @@ TclEmitInvoke( } ExceptionRangeEnds(envPtr, loopRange); - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &nonTrapFixup); + FWDJUMP( JUMP, noTrap); /* * Careful! When generating these stack unwinding sequences, the depth @@ -4535,7 +4519,7 @@ TclEmitInvoke( } FINALIZE_LOOP( loopRange); - TclFixupForwardJumpToHere(envPtr, &nonTrapFixup); + FWDLABEL( noTrap); } TclCheckStackDepth(depth+1-cleanup, envPtr); } diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 7c325ce..202d8f0 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -77,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 @@ -101,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 @@ -177,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. */ @@ -195,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 */ - int *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 @@ -404,6 +419,20 @@ typedef struct CompileEnv { * continuation line. */ } CompileEnv; +/* + * 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; +} + +/* + * Information about what the current source line is. + */ typedef struct LineInformation { ExtCmdLoc *mapPtr; /* Extended command location information for * 'info frame'. */ @@ -1049,7 +1078,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 @@ -1068,9 +1097,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. */ @@ -1168,7 +1197,7 @@ CreateJumptableNumEntry( * 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 @@ -1183,10 +1212,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; @@ -1244,9 +1273,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, @@ -1265,7 +1294,7 @@ 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 void TclFixupForwardJump(CompileEnv *envPtr, JumpFixup *jumpFixupPtr, Tcl_Size jumpDist); @@ -1293,9 +1322,9 @@ MODULE_SCOPE void TclFinalizeLoopExceptionRange(CompileEnv *envPtr, MODULE_SCOPE char * TclLiteralStats(LiteralTable *tablePtr); MODULE_SCOPE int TclLog2(long long value); #endif -MODULE_SCOPE Tcl_Size TclLocalScalar(const char *bytes, size_t numBytes, +MODULE_SCOPE Tcl_LVTIndex TclLocalScalar(const char *bytes, size_t numBytes, CompileEnv *envPtr); -MODULE_SCOPE Tcl_Size TclLocalScalarFromToken(Tcl_Token *tokenPtr, +MODULE_SCOPE Tcl_LVTIndex TclLocalScalarFromToken(Tcl_Token *tokenPtr, CompileEnv *envPtr); MODULE_SCOPE void TclOptimizeBytecode(void *envPtr); #ifdef TCL_COMPILE_DEBUG @@ -1311,9 +1340,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, Tcl_Size *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, @@ -1349,16 +1380,22 @@ MODULE_SCOPE int TclPushProcCallFrame(void *clientData, /* * Simplified form to access AuxData. * - * void *TclFetchAuxData(CompileEng *envPtr, Tcl_Size index); + * void *TclFetchAuxData(CompileEng *envPtr, Tcl_AuxDataRef index); */ #define TclFetchAuxData(envPtr, index) \ (envPtr)->auxDataArrayPtr[(index)].clientData +// Flags for TclRegisterLiteral() enum LiteralFlags { - LITERAL_ON_HEAP = 0x01, - LITERAL_CMD_NAME = 0x02, - LITERAL_UNSHARED = 0x04 + 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. */ }; /* @@ -1567,7 +1604,7 @@ TclEmitInstInt4Impl( TclEmitInstInt4Impl((op), (unsigned)(i), (envPtr)) static inline void -TclEmitInstInt14Impl( +TclEmitInstInt14( unsigned char op, unsigned i, unsigned j, @@ -1589,11 +1626,9 @@ TclEmitInstInt14Impl( TclUpdateAtCmdStart(op, envPtr); TclUpdateStackReqs(op, i, envPtr); } -#define TclEmitInstInt14(op, i, j, envPtr) \ - TclEmitInstInt14Impl((op), (unsigned)(i), (unsigned)(j), (envPtr)) static inline void -TclEmitInstInt41Impl( +TclEmitInstInt41( unsigned char op, unsigned i, unsigned j, @@ -1615,11 +1650,9 @@ TclEmitInstInt41Impl( TclUpdateAtCmdStart(op, envPtr); TclUpdateStackReqs(op, i, envPtr); } -#define TclEmitInstInt41(op, i, j, envPtr) \ - TclEmitInstInt41Impl((op), (unsigned)(i), (unsigned)(j), (envPtr)) static inline void -TclEmitInstInt44Impl( +TclEmitInstInt44( unsigned char op, unsigned i, unsigned j, @@ -1644,8 +1677,6 @@ TclEmitInstInt44Impl( TclUpdateAtCmdStart(op, envPtr); TclUpdateStackReqs(op, i, envPtr); } -#define TclEmitInstInt44(op, i, j, envPtr) \ - TclEmitInstInt44Impl((op), (unsigned)(i), (unsigned)(j), (envPtr)) /* * Function to push a Tcl object onto the Tcl evaluation stack. It emits the @@ -1653,21 +1684,18 @@ TclEmitInstInt44Impl( * This supports a maximum of 2**32 objects in a CompileEnv. */ -static inline void +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 @@ -1704,27 +1732,17 @@ TclStoreInt4AtPtrImpl( #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 get the offset to the next instruction to be issued. The ANSI C - * "prototype" for this macro is: - * - * static Tcl_Size CurrentOffset(CompileEnv *envPtr); - */ - -#define CurrentOffset(envPtr) \ - ((envPtr)->codeNext - (envPtr)->codeStart) - -/* * 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). */ @@ -1822,29 +1840,26 @@ TclGetUInt4AtPtr(const unsigned char *p) { (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)) +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 @@ -1861,7 +1876,7 @@ TclGetUInt4AtPtr(const unsigned char *p) { static inline int ExceptionRangeStarts( CompileEnv *envPtr, - Tcl_Size index) + Tcl_ExceptionRange index) { Tcl_Size offset; @@ -1876,7 +1891,7 @@ ExceptionRangeStarts( static inline void ExceptionRangeEnds( CompileEnv *envPtr, - Tcl_Size index) + Tcl_ExceptionRange index) { envPtr->exceptDepth--; envPtr->exceptArrayPtr[index].numCodeBytes = @@ -2008,26 +2023,12 @@ RegisterJumptableNum( } /* - * The type of "labels" used in FWDLABEL() and BACKLABEL(). + * The type of "labels" used in FWDLABEL() and BACKLABEL(). Logically, the + * result of CurrentOffset(), but specifically not just that. */ typedef Tcl_Size Tcl_BytecodeLabel; /* - * The type of "catch ranges" used in CATCH_RANGE(), etc. - */ -typedef Tcl_Size Tcl_ExceptionRange; - -/* - * 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; - -/* * Used to indicate that no jump is pending resolution. */ #define NO_PENDING_JUMP ((Tcl_Size) -1) @@ -2036,32 +2037,61 @@ typedef Tcl_Size Tcl_AuxDataRef; * 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,(val1),(val2),envPtr) + TclEmitInstInt14(INST_##name, (unsigned)(val1), (unsigned)(val2), envPtr) +// Issue an instruction with two four-byte arguments. #define OP44(name,val1,val2) \ - TclEmitInstInt44(INST_##name,(val1),(val2),envPtr) + 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,(val1),(val2),envPtr) - -#define PUSH(str) \ - PushStringLiteral(envPtr, str) + 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) +// 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)); \ @@ -2070,52 +2100,64 @@ typedef Tcl_Size Tcl_AuxDataRef; 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) -#define FWDJUMP(name,var) \ +// 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) -#define INVOKE(name) \ - TclEmitInvoke(envPtr,INST_##name) +// 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) -#define LENGTH_OF(str) \ - ((Tcl_Size) sizeof(str "") - 1) +// 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)) \ diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index c1d8613..13b0738 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -3447,9 +3447,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 @@ -3467,8 +3466,7 @@ CompileToInvokedCommand( 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( @@ -3476,7 +3474,6 @@ CompileToInvokedCommand( tokPtr[1].start - envPtr->source, envPtr->clNext); } - TclEmitPush(literal, envPtr); } else { CompileTokens(envPtr, tokPtr, interp); } @@ -3489,21 +3486,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/tclExecute.c b/generic/tclExecute.c index aab94a1..8820580 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -1514,8 +1514,7 @@ CompileExprObj( */ if (compEnv.codeNext == compEnv.codeStart) { - TclEmitPush(TclRegisterLiteral(&compEnv, "0", 1, 0), - &compEnv); + PushLiteral(&compEnv, "0", 1); } /* diff --git a/generic/tclLiteral.c b/generic/tclLiteral.c index 0743336..bdb2dfe 100644 --- a/generic/tclLiteral.c +++ b/generic/tclLiteral.c @@ -652,6 +652,48 @@ TclAddLiteralObj( /* *---------------------------------------------------------------------- * + * 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; +} + +/* + *---------------------------------------------------------------------- + * * AddLocalLiteralEntry -- * * Insert a new literal into a CompileEnv's local literal array. -- cgit v0.12 From f2bca09409e58de3ea24caf5d6b590f6655eb4ba Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 9 May 2025 17:55:13 +0000 Subject: Shift stubs entry --- generic/tclInt.decls | 3 +-- generic/tclIntDecls.h | 12 ++++++------ generic/tclStubInit.c | 4 ++-- 3 files changed, 9 insertions(+), 10 deletions(-) diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 8a9c865..84fac97 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -634,8 +634,7 @@ declare 257 { void TclStaticLibrary(Tcl_Interp *interp, const char *prefix, Tcl_LibraryInitProc *initProc, Tcl_LibraryInitProc *safeInitProc) } - -declare 259 { +declare 258 { int TclMSB(unsigned long long n) } diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index f2afc2a..5dae6d1 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -570,9 +570,9 @@ EXTERN void TclStaticLibrary(Tcl_Interp *interp, const char *prefix, Tcl_LibraryInitProc *initProc, Tcl_LibraryInitProc *safeInitProc); -/* Slot 258 is reserved */ -/* 259 */ +/* 258 */ EXTERN int TclMSB(unsigned long long n); +/* Slot 259 is reserved */ /* Slot 260 is reserved */ /* 261 */ EXTERN void TclUnusedStubEntry(void); @@ -839,8 +839,8 @@ typedef struct TclIntStubs { int (*tclPtrObjMakeUpvar) (Tcl_Interp *interp, Tcl_Var otherPtr, Tcl_Obj *myNamePtr, int myFlags); /* 255 */ int (*tclPtrUnsetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags); /* 256 */ void (*tclStaticLibrary) (Tcl_Interp *interp, const char *prefix, Tcl_LibraryInitProc *initProc, Tcl_LibraryInitProc *safeInitProc); /* 257 */ - void (*reserved258)(void); - int (*tclMSB) (unsigned long long n); /* 259 */ + int (*tclMSB) (unsigned long long n); /* 258 */ + void (*reserved259)(void); void (*reserved260)(void); void (*tclUnusedStubEntry) (void); /* 261 */ } TclIntStubs; @@ -1254,9 +1254,9 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclPtrUnsetVar) /* 256 */ #define TclStaticLibrary \ (tclIntStubsPtr->tclStaticLibrary) /* 257 */ -/* Slot 258 is reserved */ #define TclMSB \ - (tclIntStubsPtr->tclMSB) /* 259 */ + (tclIntStubsPtr->tclMSB) /* 258 */ +/* Slot 259 is reserved */ /* Slot 260 is reserved */ #define TclUnusedStubEntry \ (tclIntStubsPtr->tclUnusedStubEntry) /* 261 */ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index fea120e..a20fa11 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -674,8 +674,8 @@ static const TclIntStubs tclIntStubs = { TclPtrObjMakeUpvar, /* 255 */ TclPtrUnsetVar, /* 256 */ TclStaticLibrary, /* 257 */ - 0, /* 258 */ - TclMSB, /* 259 */ + TclMSB, /* 258 */ + 0, /* 259 */ 0, /* 260 */ TclUnusedStubEntry, /* 261 */ }; -- cgit v0.12 From 0e8128247f4e30a8267d342c323765b6bf6cd644 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 9 May 2025 18:13:17 +0000 Subject: [fd1585e2a1] Adopt efficient internal indexing calculation utility TclMSB(). --- generic/tclExecute.c | 29 ++------ generic/tclInt.decls | 3 + generic/tclIntDecls.h | 8 ++- generic/tclStrToD.c | 28 +------- generic/tclStubInit.c | 2 +- generic/tclTest.c | 44 ++++++++++++ generic/tclUtil.c | 180 ++++++++++++++++++++++++++++++++++++++++++++++++++ tests/brodnik.test | 72 ++++++++++++++++++++ 8 files changed, 311 insertions(+), 55 deletions(-) create mode 100644 tests/brodnik.test diff --git a/generic/tclExecute.c b/generic/tclExecute.c index c6adfd6..a1121ab 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -9554,31 +9554,10 @@ TclLog2( long long value) /* The integer for which to compute the log * base 2. The maximum output is 31 */ { - int result = 0; - - if (value > 0x7FFFFFFF) { - return 31; - } - if (value > 0xFFFF) { - value >>= 16; - result += 16; - } - if (value > 0xFF) { - value >>= 8; - result += 8; - } - if (value > 0xF) { - value >>= 4; - result += 4; - } - if (value > 0x3) { - value >>= 2; - result += 2; - } - if (value > 0x1) { - result++; - } - return result; + return (value > 0) ? ( + (value > 0x7FFFFFFF) ? + 31 : TclMSB((unsigned long long) value) + ) : 0; } /* diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 17cad13..e0abf48 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -640,6 +640,9 @@ declare 257 { void TclStaticLibrary(Tcl_Interp *interp, const char *prefix, Tcl_LibraryInitProc *initProc, Tcl_LibraryInitProc *safeInitProc) } +declare 258 { + int TclMSB(unsigned long long n) +} declare 261 { void TclUnusedStubEntry(void) diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 85c8986..6c4da2a 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -570,7 +570,8 @@ EXTERN void TclStaticLibrary(Tcl_Interp *interp, const char *prefix, Tcl_LibraryInitProc *initProc, Tcl_LibraryInitProc *safeInitProc); -/* Slot 258 is reserved */ +/* 258 */ +EXTERN int TclMSB(unsigned long long n); /* Slot 259 is reserved */ /* Slot 260 is reserved */ /* 261 */ @@ -838,7 +839,7 @@ typedef struct TclIntStubs { int (*tclPtrObjMakeUpvar) (Tcl_Interp *interp, Tcl_Var otherPtr, Tcl_Obj *myNamePtr, int myFlags); /* 255 */ int (*tclPtrUnsetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags); /* 256 */ void (*tclStaticLibrary) (Tcl_Interp *interp, const char *prefix, Tcl_LibraryInitProc *initProc, Tcl_LibraryInitProc *safeInitProc); /* 257 */ - void (*reserved258)(void); + int (*tclMSB) (unsigned long long n); /* 258 */ void (*reserved259)(void); void (*reserved260)(void); void (*tclUnusedStubEntry) (void); /* 261 */ @@ -1253,7 +1254,8 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclPtrUnsetVar) /* 256 */ #define TclStaticLibrary \ (tclIntStubsPtr->tclStaticLibrary) /* 257 */ -/* Slot 258 is reserved */ +#define TclMSB \ + (tclIntStubsPtr->tclMSB) /* 258 */ /* Slot 259 is reserved */ /* Slot 260 is reserved */ #define TclUnusedStubEntry \ diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index d4843e7..69aafaa 100644 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -2352,33 +2352,9 @@ static int RequiredPrecision( Tcl_WideUInt w) /* Number to interrogate. */ { - int rv; - unsigned int wi; + /* assert(sizeof(Tcl_WideUInt) <= sizeof(long long)) */ - if (w & ((Tcl_WideUInt)0xFFFFFFFF << 32)) { - wi = (unsigned int)(w >> 32); rv = 32; - } else { - wi = (unsigned int)w; rv = 0; - } - if (wi & 0xFFFF0000) { - wi >>= 16; rv += 16; - } - if (wi & 0xFF00) { - wi >>= 8; rv += 8; - } - if (wi & 0xF0) { - wi >>= 4; rv += 4; - } - if (wi & 0xC) { - wi >>= 2; rv += 2; - } - if (wi & 0x2) { - wi >>= 1; ++rv; - } - if (wi & 0x1) { - ++rv; - } - return rv; + return w ? 1 + TclMSB((unsigned long long) w) : 0; } /* diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 9bfce36..f7fd5b0 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -673,7 +673,7 @@ static const TclIntStubs tclIntStubs = { TclPtrObjMakeUpvar, /* 255 */ TclPtrUnsetVar, /* 256 */ TclStaticLibrary, /* 257 */ - 0, /* 258 */ + TclMSB, /* 258 */ 0, /* 259 */ 0, /* 260 */ TclUnusedStubEntry, /* 261 */ diff --git a/generic/tclTest.c b/generic/tclTest.c index d58478d..72ed211 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -251,6 +251,7 @@ static Tcl_ObjCmdProc TestlinkarrayCmd; static Tcl_ObjCmdProc TestlistrepCmd; static Tcl_ObjCmdProc TestlocaleCmd; static Tcl_ObjCmdProc TestmainthreadCmd; +static Tcl_ObjCmdProc TestmsbObjCmd; static Tcl_ObjCmdProc TestsetmainloopCmd; static Tcl_ObjCmdProc TestexitmainloopCmd; static Tcl_ObjCmdProc TestpanicCmd; @@ -647,6 +648,7 @@ Tcltest_Init( Tcl_CreateObjCommand(interp, "testlistrep", TestlistrepCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testlocale", TestlocaleCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "testmsb", TestmsbObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testpanic", TestpanicCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testparseargs", TestparseargsCmd,NULL,NULL); Tcl_CreateObjCommand(interp, "testparser", TestparserCmd, @@ -4003,6 +4005,48 @@ CleanupTestSetassocdataTests( /* *---------------------------------------------------------------------- * + * TestmsbObjCmd -- + * + * This procedure implements the "testmsb" command. It is + * used for testing the TclMSB() routine. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestmsbObjCmd( + TCL_UNUSED(void *), + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* The argument objects. */ +{ + Tcl_WideInt w = 0; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "integer"); + return TCL_ERROR; + } + if (TCL_OK != Tcl_GetWideIntFromObj(interp, objv[1], &w)) { + return TCL_ERROR; + } + if (w <= 0) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("argument must be positive",-1)); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewIntObj(TclMSB((unsigned long long)w))); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * TestparserCmd -- * * This procedure implements the "testparser" command. It is diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 4beb25d..7940b66 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -19,6 +19,11 @@ #include "tclTomMath.h" #include +#if defined(_MSC_VER) && defined(_WIN64) +# include +# pragma intrinsic(_BitScanReverse64) +#endif + /* * The absolute pathname of the executable in which this Tcl library is * running. @@ -4611,6 +4616,181 @@ TclReToGlob( } /* + *---------------------------------------------------------------------- + * + * TclMSB -- + * + * Given a unsigned long long non-zero value n, return the index of + * the most significant bit in n that is set. This is equivalent to + * returning trunc(log2(n)). It's also equivalent to the largest + * integer k such that 2^k <= n. + * + * This routine is adapted from Andrej Brodnik, "Computation of the + * Least Significant Set Bit", pp 7-10, Proceedings of the 2nd + * Electrotechnical and Computer Science Conference, Portoroz, + * Slovenia, 1993. The adaptations permit the computation to take + * place within unsigned long long values without the need for double + * length buffers for calculation. They also fill in a number of + * details the paper omits or leaves unclear. + * + * Results: + * The index of the most significant set bit in n, a value between + * 0 and 63, inclusive. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclMSB( + unsigned long long n) +{ + /* assert ( 64 == CHAR_BIT * sizeof(unsigned long long) ); */ + /* assert ( n != 0 ); */ + + /* + * Many platforms offer access to this functionality through + * compiler specific incantations that exploit processor + * instructions. Add more as appropriate. + */ + +#if defined(_MSC_VER) && defined(_WIN64) + /* + * This candidate implementation for Microsoft compilers is + * untested. (Remove this comment when someone tests it and + * either finds it working, or fixes any brokenness.) + */ + unsigned long result; + + (void) _BitScanReverse64(&result, (unsigned __int64)n); + return (int)result; + +#elif defined(__GNUC__) && ((__GNUC__ > 3) || (__GNUC__ == 3 && __GNUC_MINOR__ >= 4)) + + /* + * The GNU Compiler Collection offers this builtin routine + * starting with version 3.4, released 2004. + * clzll() = Count of Leading Zeroes in a Long Long + * NOTE: we rely on input constraint (n != 0). + */ + + return 63 - __builtin_clzll(n); + +#else + + /* + * For a byte, consider two masks, C1 = 10000000 selecting just + * the high bit, and C2 = 01111111 selecting all other bits. + * Then for any byte value n, the computation + * LEAD(n) = C1 & (n | (C2 + (n & C2))) + * will leave all bits but the high bit unset, and will have the + * high bit set iff n!=0. The whole thing is an 8-bit test + * for being non-zero. For an 8-byte n, each byte can have + * the test applied all at once, with combined masks. + */ + const unsigned long long C1 = 0x8080808080808080; + const unsigned long long C2 = 0x7F7F7F7F7F7F7F7F; +#define LEAD(n) (C1 & (n | (C2 + (n & C2)))) + + /* + * To shift a bit to a new place, multiplication by 2^k will do. + * To shift the top 7 bits produced by the LEAD test to the high + * 7 bits of the entire long long, multiply by the right sum of + * powers of 2. In this case + * Q = 1 + 2^7 + 2^14 + 2^21 + 2^28 + 2^35 + 2^42 + * Then shift those 7 bits down to the low 7 bits of the long long. + * The key to making this work is that none of the shifted bits + * collide with each other in the top 7-bit destination. + * Note that we lose the bit that indicates whether the low byte + * is non-zero. That doesn't matter because we require the original + * value n to be non-zero, so if all other bytes signal to be zero, + * we know the low byte is non-zero, and if one of the other bytes + * signals non-zero, we just don't care what the low byte is. + */ + const unsigned long long Q = 0x0000040810204081; + + /* + * To place a copy of a 7-bit value in each of 7 bytes in + * a long long, just multply by the right value. In this case + * P = 0x00 01 01 01 01 01 01 01 + * We don't put a copy in the high byte since analysis of the + * remaining steps in the algorithm indicates we do not need it. + */ + const unsigned long long P = 0x0001010101010101; + + /* + * With 7 copies of the LEAD value, we can now apply 7 masks + * to it in a single step by an & against the right value. + * B = 00000000 01111111 01111110 01111100 + * 01111000 01110000 01100000 01000000 + * The higher the MSB of the copied value is, the more of the + * B-masked bytes stored in t will be non-zero. + */ + const unsigned long long B = 0x007F7E7C78706040; + unsigned long long t = B & P * (LEAD(n) * Q >> 57); + + /* + * We want to get a count of the non-zero bytes stored in t. + * First use LEAD(t) to create a set of high bits signaling + * non-zero values as before. Call this value + * X = x6*2^55 +x5*2^47 +x4*2^39 +x3*2^31 +x2*2^23 +x1*2^15 +x0*2^7 + * Then notice what multiplication by + * P = 2^48 + 2^40 + 2^32 + 2^24 + 2^16 + 2^8 + 1 + * produces: + * P*X = x0*2^7 + (x0 + x1)*2^15 + ... + * ... + (x0 + x1 + x2 + x3 + x4 + x5 + x6) * 2^55 + ... + * ... + (x5 + x6)*2^95 + x6*2^103 + * The high terms of this product are going to overflow the long long + * and get lost, but we don't care about them. What we care is that + * the 2^55 term is exactly the sum we seek. We shift the product + * down by 55 bits and then mask away all but the bottom 3 bits + * (Max sum can be 7) we get exactly the count of non-zero B-masked + * bytes. By design of the mask, this count is the index of the + * MSB of the LEAD value. It indicates which byte of the original + * value contains the MSB of the original value. + */ +#define SUM(t) (0x7 & (int)(LEAD(t) * P >> 55)); + + /* + * Multiply by 8 to get the number of bits to shift to place + * that MSB-containing byte in the low byte. + */ + int k = 8 * SUM(t); + + /* + * Shift the MSB byte to the low byte. Then shift one more bit. + * Since we know the MSB byte is non-zero we only need to compute + * the MSB of the top 7 bits. If all top 7 bits are zero, we know + * the bottom bit is the 1 and the correct index is 0. Compute the + * MSB of that value by the same steps we did before. + */ + t = B & P * (n >> k >> 1); + + /* + * Add the index of the MSB of the byte to the index of the low + * bit of that byte computed before to get the final answer. + */ + return k + SUM(t); + + /* Total operations: 33 + * 10 bit-ands, 6 multiplies, 4 adds, 5 rightshifts, + * 3 assignments, 3 bit-ors, 2 typecasts. + * + * The whole task is one direct computation. + * No branches. No loops. + * + * 33 operations cannot beat one instruction, so assembly + * wins and should be used wherever possible, but this isn't bad. + */ + +#undef SUM +#undef LEAD +#endif +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/tests/brodnik.test b/tests/brodnik.test new file mode 100644 index 0000000..a74f871 --- /dev/null +++ b/tests/brodnik.test @@ -0,0 +1,72 @@ +# This file contains a collection of tests for the routine TclMSB() in the +# file tclUtil.c. +# +# Contributions from Don Porter, NIST, 2013. (not subject to US copyright) +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +package require Tcl 8.6- +package require tcltest 2 + +namespace eval ::tcl::test::brodnik { + namespace import ::tcltest::loadTestedCommands + namespace import ::tcltest::testConstraint + namespace import ::tcltest::test + namespace import ::tcltest::cleanupTests + + loadTestedCommands + try {package require tcl::test} + testConstraint testmsb [expr {[namespace which -command testmsb] ne {}}] + + namespace eval tcl { + namespace eval mathfunc { + proc log2 {i} { + set k 0 + while {[set i [expr {$i>>1}]]} { + incr k + } + return $k + } + } + } + + # Test out-of-range rejection + test brodnik-1.0 {TclMSB correctness} -constraints testmsb -body { + testmsb 0 + } -returnCodes error -match glob -result * + + # Tests for values with MSB in the low block + variable v 1 + while {$v < 1<<8} { + test brodnik-1.$v {TclMSB correctness} testmsb { + testmsb $v + } [expr {int(log2($v))}] + incr v + } + + variable i 8 + while {$i < 8*$::tcl_platform(pointerSize) - 1} { + + variable j -1 + while {$j < 2} { + set v [expr {(1<<$i) + $j}] + + test brodnik-2.$i.$j {TclMSB correctness} testmsb { + testmsb $v + } [expr {int(log2($v))}] + + incr j + } + incr i + } + + # Test out-of-range rejection + test brodnik-3.0 {TclMSB correctness} -constraints testmsb -body { + testmsb [expr 1<<64] + } -returnCodes error -match glob -result * + + cleanupTests +} +namespace delete ::tcl::test::brodnik +return -- cgit v0.12 From ca052cf9edbdd423470e8975e03e7b0b0b5e9072 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 10 May 2025 09:26:35 +0000 Subject: Notes on expanded-lappend: requires a deep fix elsewhere, so for a future date --- generic/tclCompCmdsGR.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 4237b32..a06e022 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -818,7 +818,8 @@ TclCompileLappendCmd( int isScalar; Tcl_LVTIndex localIndex; - /* TODO: Consider support for compiling expanded args. */ + /* TODO: Consider support for compiling expanded args. + * REQUIRES: Fixing INST_LAPPEND_LIST (etc.) in zero-length list case. */ if (numWords < 3 || numWords > UINT_MAX) { return TCL_ERROR; } -- cgit v0.12 From 7d6d88eb1cdc002cf916cdd894d25c4689c4f2b7 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sat, 10 May 2025 15:12:04 +0000 Subject: ledit and lreplace tests for new abstract lists --- generic/tclListTypes.c | 144 ++++++++++++++++++++++++++++++------------------- tests/listTypes.test | 132 ++++++++++++++++++++++++++++++++++++++++++--- 2 files changed, 213 insertions(+), 63 deletions(-) diff --git a/generic/tclListTypes.c b/generic/tclListTypes.c index a373166..9a80643 100644 --- a/generic/tclListTypes.c +++ b/generic/tclListTypes.c @@ -81,6 +81,23 @@ static inline Tcl_Size TclObjArrayElems(TclObjArray *arrayPtr, Tcl_Obj ***objPtr return arrayPtr->nelems; } +/* TODO - move to tclInt and use in other files 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; +} + /* *------------------------------------------------------------------------ * @@ -555,15 +572,15 @@ Tcl_ListObjRepeat( * lrangeType - * * lrangeType is an abstract list type holding a range of elements from a - * given list. The range is specified by a start and end index. + * given list. The range is specified by a start index and count of elements. * The type is a descriptor stored in the otherValuePtr field of the Tcl_Obj. * ------------------------------------------------------------------------ */ typedef struct LrangeRep { Tcl_Obj *srcListPtr; /* Source list */ Tcl_Size refCount; /* Reference count */ - Tcl_Size start; /* Start index */ - Tcl_Size end; /* End index */ + Tcl_Size srcIndex; /* Start index of range in source list */ + Tcl_Size rangeLen; /* Number of elements in range */ } LrangeRep; static void LrangeFreeIntrep(Tcl_Obj *objPtr); @@ -616,19 +633,22 @@ LrangeMeetsLengthCriteria( /* Returns a new lrangeType object that references the source list */ static int LrangeNew( - Tcl_Obj *sourcePtr, /* Source for the range operation */ - Tcl_Size start, /* Start of range */ - Tcl_Size end, /* End of range */ + 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(sourcePtr); - repPtr->srcListPtr = sourcePtr; + Tcl_IncrRefCount(srcPtr); repPtr->refCount = 1; - repPtr->start = start; - repPtr->end = end; + repPtr->srcListPtr = srcPtr; + repPtr->srcIndex = srcIndex; + repPtr->rangeLen = rangeLen; TclNewObj(resultPtr); TclInvalidateStringRep(resultPtr); resultPtr->internalRep.otherValuePtr = repPtr; @@ -664,7 +684,7 @@ Tcl_Size LrangeTypeLength(Tcl_Obj *objPtr) { LrangeRep *repPtr = (LrangeRep *)objPtr->internalRep.otherValuePtr; - return repPtr->end - repPtr->start + 1; + return repPtr->rangeLen; } /* Implementation of Tcl_ObjType.indexProc for lrangeType */ @@ -676,13 +696,13 @@ LrangeTypeIndex( Tcl_Obj **elemPtrPtr) /* Returned element */ { LrangeRep *repPtr = (LrangeRep *)objPtr->internalRep.otherValuePtr; - Tcl_Size len = repPtr->end - repPtr->start + 1; - if (index < 0 || index >= len) { - *elemPtrPtr = NULL; - return TCL_OK; + Tcl_Size len = repPtr->rangeLen; + if (index < 0 || index >= repPtr->rangeLen) { + *elemPtrPtr = NULL; + return TCL_OK; } return Tcl_ListObjIndex( - interp, repPtr->srcListPtr, repPtr->start + index, elemPtrPtr); + interp, repPtr->srcListPtr, repPtr->srcIndex + index, elemPtrPtr); } /* Implementation of Tcl_ObjType.sliceProc for lrangeType */ @@ -696,39 +716,50 @@ LrangeSlice( { assert(objPtr->typePtr == &lrangeType); + Tcl_Size rangeLen; LrangeRep *repPtr = (LrangeRep *)objPtr->internalRep.otherValuePtr; - Tcl_Size len = repPtr->end - repPtr->start + 1; + Tcl_Obj *sourcePtr = repPtr->srcListPtr; - if (start < 0) { - start = 0; - } - if (end >= len) { - end = len - 1; - } - if (start > end) { + rangeLen = + TclNormalizeRangeLimits(&start, &end, repPtr->rangeLen); + if (rangeLen == 0) { TclNewObj(*resultPtrPtr); return TCL_OK; } - /* * If the original source list was also a lrangeType, we can reference - * *its* source directly. Moreover, if objPtr is unshared, reuse it. - * Do this recursively until we reach a non-lrangeType. + * *its* source directly. Do this recursively until we reach a + * non-lrangeType. */ - Tcl_Obj *sourcePtr = repPtr->srcListPtr; + Tcl_Size newSrcIndex = start + repPtr->srcIndex; while (sourcePtr->typePtr == &lrangeType) { - LrangeRep *sourceRepPtr = (LrangeRep *)sourcePtr->internalRep.otherValuePtr; - start += sourceRepPtr->start; - end += sourceRepPtr->start; - sourcePtr = sourceRepPtr->srcListPtr; + LrangeRep *nextRepPtr = (LrangeRep *)sourcePtr->internalRep.otherValuePtr; + newSrcIndex += nextRepPtr->srcIndex; + sourcePtr = nextRepPtr->srcListPtr; } + /* * At this point, sourcePtr is a non-lrangeType that will be the source - * Tcl_Obj for the returned object. The start and end indices are indices - * into this. Note it is possible that sourcePtr is repPtr->srcListPtr. + * Tcl_Obj for the returned object. newSrcIndex is an index into this. + * Note it is possible that sourcePtr is repPtr->srcListPtr if the range + * target is not itself a range. */ + Tcl_Size sourceLen; + if (TclListObjLength(interp, sourcePtr, &sourceLen) != TCL_OK) { + /* Cannot fail because how rangeType's are constructed but ... */ + return TCL_ERROR; + } + /* + * A range is always smaller than its source thus the following must + * hold even for recursive ranges. + * TODO - change to an assert() + */ + if ((newSrcIndex+rangeLen) > sourceLen) { + Tcl_Panic("lrangeType: (newSrcIndec+rangeLen) > sourceLen"); + } + /* * We will only use the lrangeType abstract list if the following * conditions are met: @@ -736,30 +767,37 @@ LrangeSlice( * own range operation with better performance and additional features. * 2. The length criteria for using rangeType are met. */ - if (TclListObjLength(interp, sourcePtr, &len) != TCL_OK) { - /* Cannot fail because how rangeType's are constructed but ... */ - return TCL_ERROR; - } - Tcl_Size rangeLen = end - start + 1; - if (objPtr->typePtr == &tclListType || - !LrangeMeetsLengthCriteria(rangeLen, len)) { - /* Conditions not met, create non-abstract list */ - *resultPtrPtr = TclListObjRange(interp, objPtr, start, end); + 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; } if (!Tcl_IsShared(objPtr) && repPtr->refCount < 2) { /* Reuse this objPtr */ - repPtr->start = start; - repPtr->end = end; + repPtr->srcIndex = newSrcIndex; + repPtr->rangeLen = rangeLen; + Tcl_IncrRefCount(sourcePtr); /* Incr before decr ! */ + Tcl_DecrRefCount(repPtr->srcListPtr); repPtr->srcListPtr = sourcePtr; - Tcl_IncrRefCount(sourcePtr); Tcl_InvalidateStringRep(objPtr); *resultPtrPtr = objPtr; return TCL_OK; } else { - return LrangeNew(sourcePtr, start, end, resultPtrPtr); + return LrangeNew(sourcePtr, newSrcIndex, rangeLen, resultPtrPtr); } } @@ -798,13 +836,8 @@ Tcl_ListObjRange( return result; } - if (start < 0) { - start = 0; - } - if (end >= srcLen) { - end = srcLen - 1; - } - if (start > end) { + Tcl_Size rangeLen = TclNormalizeRangeLimits(&start, &end, srcLen); + if (rangeLen == 0) { TclNewObj(*resultPtrPtr); return TCL_OK; } @@ -824,7 +857,6 @@ Tcl_ListObjRange( * own range operation with better performance and additional features. * 2. The length criteria for using rangeType are met. */ - Tcl_Size rangeLen = end - start + 1; if (objPtr->typePtr == &tclListType || !LrangeMeetsLengthCriteria(rangeLen, srcLen)) { /* Conditions not met, create non-abstract list */ @@ -833,5 +865,5 @@ Tcl_ListObjRange( } /* Create a lrangeType referencing the original source list */ - return LrangeNew(objPtr, start, end, resultPtrPtr); + return LrangeNew(objPtr, start, rangeLen, resultPtrPtr); } \ No newline at end of file diff --git a/tests/listTypes.test b/tests/listTypes.test index 4f4e88e..0354627 100644 --- a/tests/listTypes.test +++ b/tests/listTypes.test @@ -66,7 +66,7 @@ namespace eval listtype { # 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 1000; # Multiple of 4 because of assumptions in tests + variable largeListLength 120; # Multiple of 4 because of assumptions in tests proc getListType {l} { set ltype [testobj objtype $l] @@ -86,6 +86,10 @@ namespace eval listtype { } } + proc isAbstractList {l} { + return [expr {[getListType $l] ni {list spanlist}}] + } + # Returns a list of length $largeListLength of the specified type proc makeList {type args} { variable largeListLength @@ -178,7 +182,7 @@ namespace eval listtype { lappend outerList $nestedList } # lrange on a list or spanlist will return a spanlist, not rangeList - # so reverse it + # so reverse it first. lrange [lreverse $outerList] 0 end-1 } default { @@ -380,27 +384,141 @@ namespace eval listtype { arithseries {set ltype2 arithseries} default {set ltype2 rangeList} } - testdef lassign-$ltype-unshared-0 "lassign unshared list of type $ltype" -body { + + 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-0 "lassign shared list of type $ltype" -body { + + 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-0 "lassign small list of type $ltype should always be non-abstract list" -body { + 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 - TBD + # 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 - TBD + # 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 - TBD ################################################################ -- cgit v0.12 From edf5dfe3e92a3f856aeafa26600c50c5090da87f Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 12 May 2025 06:46:42 +0000 Subject: fix INST_LAPPEND_LIST semantics with zero-length lists --- generic/tclCompCmdsGR.c | 9 ++++++--- generic/tclExecute.c | 42 ++++++++++++++++++++++++------------------ 2 files changed, 30 insertions(+), 21 deletions(-) diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index a06e022..b4291e7 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -818,12 +818,15 @@ TclCompileLappendCmd( int isScalar; Tcl_LVTIndex localIndex; - /* TODO: Consider support for compiling expanded args. - * REQUIRES: Fixing INST_LAPPEND_LIST (etc.) in zero-length list case. */ - if (numWords < 3 || numWords > UINT_MAX) { + /* TODO: Consider support for compiling expanded args. */ + if (numWords < 2 || numWords > UINT_MAX) { return TCL_ERROR; } + /* + * 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. + */ if (numWords != 3 || !EnvHasLVT(envPtr)) { goto lappendMultiple; } diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 8820580..dd643e4 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -3440,7 +3440,7 @@ TEBCresume( TRACE_ERROR(interp); goto gotError; } - if (TclIsVarDirectReadable(varPtr) + if (objc && TclIsVarDirectReadable(varPtr) && TclIsVarDirectWritable(varPtr)) { goto lappendListDirect; } @@ -3466,7 +3466,7 @@ TEBCresume( 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) @@ -3524,8 +3524,7 @@ TEBCresume( lappendList: opnd = -1; - if (TclListObjGetElements(interp, valuePtr, &objc, &objv) - != TCL_OK) { + if (TclListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK) { TRACE_ERROR(interp); goto gotError; } @@ -3557,26 +3556,31 @@ 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; } } @@ -3584,14 +3588,16 @@ TEBCresume( objResultPtr = TclPtrSetVarIdx(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, valueToAssign, TCL_LEAVE_ERR_MSG, opnd); CACHE_STACK_INFO(); - if (!objResultPtr) { - errorInLappendListPtr: - TRACE_ERROR(interp); - goto gotError; - } + } + skipLappendListAssign: + if (!objResultPtr) { + goto errorInLappendListPtr; } TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); NEXT_INST_V(pcAdjustment, cleanup, 1); + errorInLappendListPtr: + TRACE_ERROR(interp); + goto gotError; } /* -- cgit v0.12 From 2ab4e97376997e912cd1dc7fa3eb42bd3be00ad1 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 12 May 2025 08:36:51 +0000 Subject: _BitScanReverse64() is tested now, so remove comment. Slight speedup for TclLog2, using OR --- generic/tclExecute.c | 6 ++---- generic/tclUtil.c | 5 ----- 2 files changed, 2 insertions(+), 9 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index a1121ab..227f623 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -9554,10 +9554,8 @@ TclLog2( 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 > 0x7FFFFFFF) ? 31 + : TclMSB((unsigned long long) value | 1); } /* diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 7940b66..bab734e 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -4657,11 +4657,6 @@ TclMSB( */ #if defined(_MSC_VER) && defined(_WIN64) - /* - * This candidate implementation for Microsoft compilers is - * untested. (Remove this comment when someone tests it and - * either finds it working, or fixes any brokenness.) - */ unsigned long result; (void) _BitScanReverse64(&result, (unsigned __int64)n); -- cgit v0.12 From 196f398e9f36fc7c126b4350b81200d5f50453e5 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 12 May 2025 08:42:13 +0000 Subject: Forget speedup of TclLog2: Negative numbers should behave as 0. --- generic/tclExecute.c | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 227f623..a1121ab 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -9554,8 +9554,10 @@ TclLog2( long long value) /* The integer for which to compute the log * base 2. The maximum output is 31 */ { - return (value > 0x7FFFFFFF) ? 31 - : TclMSB((unsigned long long) value | 1); + return (value > 0) ? ( + (value > 0x7FFFFFFF) ? + 31 : TclMSB((unsigned long long) value) + ) : 0; } /* -- cgit v0.12 From de090950d0a4e6800b6b145bf99b911677ec68a2 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 12 May 2025 11:33:33 +0000 Subject: Remove Tcl_GetString() stub entry: it isn't used anywhere any more --- generic/tcl.decls | 5 +---- generic/tclDecls.h | 10 +++------- generic/tclObj.c | 55 --------------------------------------------------- generic/tclStubInit.c | 15 +------------- 4 files changed, 5 insertions(+), 80 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index bf18d2c..f051350 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -1038,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) } @@ -2360,7 +2357,7 @@ declare 689 { void Tcl_SetWideUIntObj(Tcl_Obj *objPtr, Tcl_WideUInt uwideValue) } -# ----- BASELINE -- FOR -- 8.7.0 / 9.0.0 ----- # +# ----- BASELINE -- FOR -- 9.0.0 ----- # declare 690 { int Tcl_IsEmpty(Tcl_Obj *obj) diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 1a72149..c03114c 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -894,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 */ @@ -2221,7 +2220,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 */ @@ -3215,8 +3214,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 \ @@ -4003,8 +4001,6 @@ extern const TclStubs *tclStubsPtr; # endif #endif -#undef Tcl_GetString -#undef Tcl_GetUnicode #define Tcl_GetString(objPtr) \ Tcl_GetStringFromObj(objPtr, (Tcl_Size *)NULL) #define Tcl_GetUnicode(objPtr) \ diff --git a/generic/tclObj.c b/generic/tclObj.c index c0231e2..59ef8aa 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -1583,61 +1583,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 diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index a20fa11..d9f311a 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 @@ -1160,7 +1147,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 */ -- cgit v0.12 From 550e49b9df3ed320b3a0ddbe17e40737d6117b17 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Mon, 12 May 2025 15:50:18 +0000 Subject: Add tests for more list operations and variable indices (when they have a separate code path from literals) --- generic/tclListTypes.c | 25 +++-- tests/listRep.test | 1 + tests/listTypes.test | 260 ++++++++++++++++++++++++++++++++++++++++++++----- 3 files changed, 251 insertions(+), 35 deletions(-) diff --git a/generic/tclListTypes.c b/generic/tclListTypes.c index 9a80643..313be62 100644 --- a/generic/tclListTypes.c +++ b/generic/tclListTypes.c @@ -36,7 +36,7 @@ typedef struct TclObjArray { * given Tcl_Obj elements, incrementing their reference counts. * The reference count of the array itself is initialized to 0. */ -static inline TclObjArray * +static TclObjArray * TclObjArrayNew(size_t nelems, Tcl_Obj * const elemPtrs[]) { TclObjArray *arrayPtr = (TclObjArray *)Tcl_Alloc( @@ -57,6 +57,16 @@ 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. @@ -65,23 +75,22 @@ static inline void TclObjArrayUnref(TclObjArray *arrayPtr) { if (arrayPtr->refCount <= 1) { - for (Tcl_Size i = 0; i < arrayPtr->nelems; i++) { - Tcl_DecrRefCount(arrayPtr->elemPtrs[i]); - } - Tcl_Free(arrayPtr); + 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) +static inline Tcl_Size +TclObjArrayElems(TclObjArray *arrayPtr, Tcl_Obj ***objPtrPtr) { *objPtrPtr = arrayPtr->elemPtrs; return arrayPtr->nelems; } -/* TODO - move to tclInt and use in other files as well */ +/* TODO - 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) { @@ -196,7 +205,7 @@ static void TclAbstractListUpdateString (Tcl_Obj *objPtr) } /* - * lrepeatType - + * lreverseType - * * ------------------------------------------------------------------------ * lreverseType is an abstract list type that contains the same elements as a 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 index 0354627..d209293 100644 --- a/tests/listTypes.test +++ b/tests/listTypes.test @@ -13,25 +13,27 @@ # - "repeatedList" - an abstract list holding repeated elements # - "reversedList" - an abstract list that is the reverse of another list # -# All list operations, loops, {*} expansion need to be tested with each of the -# above types. The first three of these are already tested in cmdIL.test, -# lseq.test, listrep.test etc. but are included here for completeness. Note the -# tests here do not test command options to the commands as those are already -# tested in the aforementioned files. +# 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. # # For the abstract list types not tested elsewhere, # - verify constructor commands return the expected type # - generated string representations - -# Test list operations include combinations of -# - Compiled / uncompiled operation -# - Shared / unshared operands -# - List internal representation types. -# # TODO - see comments to testlistobj # TODO - see listobjmemcheck and indexmemcheck in listObj.test # TODO - lrepeat/lreverse string generation when starting with # -# TODO -lrepeat/lreverse list of braces +# TODO - lrepeat/lreverse list of braces # TODO - nested lrepeat with index list and separate indices # TODO - nested list combinations. Verify none of the lists shimmer # TODO - [lreverse [lreverse]] should retrieve original list. @@ -61,6 +63,12 @@ namespace eval listtype { variable indices variable result + # Compiled bytecode depends on whether arguments are literals or + # variables. So test variations are needed for both. + variable zero 0 + variable minusOne -1 + variable 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 @@ -90,6 +98,11 @@ namespace eval listtype { return [expr {[getListType $l] ni {list spanlist}}] } + # Convert the given list to non abstract + proc makeNonAbstract {l} { + list {*}$l + } + # Returns a list of length $largeListLength of the specified type proc makeList {type args} { variable largeListLength @@ -222,6 +235,10 @@ namespace eval listtype { } dict lappend args -constraints testobj + set cleanup [dict getwithdefault $args -cleanup {}] + dict unset args -cleanup + append 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] @@ -232,18 +249,21 @@ namespace eval listtype { # 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" \ - $body] + "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 \ + -body testxproc -cleanup $cleanup \ {*}$args] } @@ -263,15 +283,25 @@ namespace eval listtype { # lindex tests - single index foreach ltype $listTypes { lassign [getFirstAndLast $ltype] first last - testdef lindex-$ltype-shared-0 "lindex 0 of shared type $ltype" -body { + + 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-unshared-0 "lindex 0 of unshared type $ltype" -body { + 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] @@ -520,19 +550,139 @@ namespace eval listtype { } ################################################################ - # linsert tests - TBD + # 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]] + } + ################################################################ # lreverse tests - TBD ################################################################ # lsearch tests - TBD ################################################################ # lset tests - TBD + ################################################################ - # lsort tests - TBD + # 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 "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 "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 - TBD + # 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 - TBD + # 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)] {}]] + + } + + ################################################################ # lrange tests - TBD ################################################################ @@ -541,12 +691,68 @@ namespace eval listtype { # join tests - TBD ################################################################ # lrepeat tests - TBD + ################################################################ # lpop tests - TBD + + ################################################################ - # lremove tests - TBD + # 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]] + } } -- cgit v0.12 From fd8f8e85b08b23121355fe4ce464c0f6cf2cf5bc Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 13 May 2025 10:43:02 +0000 Subject: Expand comments and tidy up a little in the [lappend] compiler --- generic/tclCompCmdsGR.c | 64 ++++++++++++++++++++++++++++++------------------- 1 file changed, 40 insertions(+), 24 deletions(-) diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index b4291e7..7f1e917 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -824,14 +824,6 @@ TclCompileLappendCmd( } /* - * 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. - */ - if (numWords != 3 || !EnvHasLVT(envPtr)) { - 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 * frame slot (entry in the array of local vars) if we are compiling a @@ -841,22 +833,25 @@ TclCompileLappendCmd( varTokenPtr = TokenAfter(parsePtr->tokenPtr); PushVarNameWord(varTokenPtr, 0, &localIndex, &isScalar, 1); - + /* - * If we are doing an assignment, push the new value. In the no values - * case, create an empty object. + * 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. */ - - if (numWords > 2) { - valueTokenPtr = TokenAfter(varTokenPtr); - PUSH_TOKEN( valueTokenPtr, 2); + if (numWords != 3 || !EnvHasLVT(envPtr)) { + goto lappendMultiple; } /* - * Emit instructions to set/get the variable. + * We are doing an assignment, so push the new value. */ + valueTokenPtr = TokenAfter(varTokenPtr); + PUSH_TOKEN( valueTokenPtr, 2); + /* + * Emit instructions to set/get the variable. + * * The *_STK opcodes should be refactored to make better use of existing * LOAD/STORE instructions. */ @@ -874,18 +869,39 @@ TclCompileLappendCmd( 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(varTokenPtr, 0, &localIndex, &isScalar, 1); - valueTokenPtr = TokenAfter(varTokenPtr); - for (i = 2 ; i < numWords ; i++) { - PUSH_TOKEN( valueTokenPtr, i); - valueTokenPtr = TokenAfter(valueTokenPtr); + + /* + * Concatenate all our remaining arguments into a list. + * TODO: Turn this into an expand-handling list building sequence. + */ + + if (numWords == 2) { + PUSH( ""); + } else { + valueTokenPtr = TokenAfter(varTokenPtr); + for (i = 2 ; i < numWords ; i++) { + PUSH_TOKEN( valueTokenPtr, i); + valueTokenPtr = TokenAfter(valueTokenPtr); + } + OP4( LIST, numWords - 2); } - OP4( LIST, numWords - 2); + + /* + * Append the items of the list to the variable. The implementation of + * these opcodes handles all the special cases that [lappend] knows about. + */ + if (isScalar) { if (localIndex < 0) { OP( LAPPEND_LIST_STK); -- cgit v0.12 From 94d3df371766d22ab7f5df4fed994b7edadd9762 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 13 May 2025 15:41:21 +0000 Subject: Put (back) Tcl_CreateHashEntry() stub entry. For better upwards compatibility with TIP #717. Not used in Tcl 9.0 --- generic/tcl.decls | 4 ++++ generic/tclDecls.h | 10 +++++++--- generic/tclHash.c | 27 +++++++++++++++++---------- generic/tclStubInit.c | 13 ++++++++++++- 4 files changed, 40 insertions(+), 14 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 2ab1f7f..ae5e04c 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -1303,6 +1303,10 @@ declare 417 { declare 418 { int Tcl_IsChannelExisting(const char *channelName) } +declare 422 { + Tcl_HashEntry *Tcl_CreateHashEntry(Tcl_HashTable *tablePtr, + const void *key, int *newPtr) +} declare 423 { void Tcl_InitCustomHashTable(Tcl_HashTable *tablePtr, int keyType, const Tcl_HashKeyType *typePtr) diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 67d4108..e78638f 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1102,7 +1102,9 @@ EXTERN int Tcl_IsChannelExisting(const char *channelName); /* Slot 419 is reserved */ /* Slot 420 is reserved */ /* Slot 421 is reserved */ -/* Slot 422 is reserved */ +/* 422 */ +EXTERN Tcl_HashEntry * Tcl_CreateHashEntry(Tcl_HashTable *tablePtr, + const void *key, int *newPtr); /* 423 */ EXTERN void Tcl_InitCustomHashTable(Tcl_HashTable *tablePtr, int keyType, const Tcl_HashKeyType *typePtr); @@ -2308,7 +2310,7 @@ typedef struct TclStubs { void (*reserved419)(void); void (*reserved420)(void); void (*reserved421)(void); - void (*reserved422)(void); + 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 */ @@ -3377,7 +3379,8 @@ extern const TclStubs *tclStubsPtr; /* Slot 419 is reserved */ /* Slot 420 is reserved */ /* Slot 421 is reserved */ -/* Slot 422 is reserved */ +#define Tcl_CreateHashEntry \ + (tclStubsPtr->tcl_CreateHashEntry) /* 422 */ #define Tcl_InitCustomHashTable \ (tclStubsPtr->tcl_InitCustomHashTable) /* 423 */ #define Tcl_InitObjHashTable \ @@ -4028,6 +4031,7 @@ extern const TclStubs *tclStubsPtr; #undef Tcl_GetString #undef Tcl_GetUnicode +#undef Tcl_CreateHashEntry #define Tcl_GetString(objPtr) \ Tcl_GetStringFromObj(objPtr, (Tcl_Size *)NULL) #define Tcl_GetUnicode(objPtr) \ diff --git a/generic/tclHash.c b/generic/tclHash.c index 9bdb079..7e2a876 100644 --- a/generic/tclHash.c +++ b/generic/tclHash.c @@ -14,6 +14,12 @@ #include "tclInt.h" /* + * Prevent macros from clashing with function definitions. + */ + +#undef Tcl_CreateHashEntry + +/* * When there are this many entries per bucket, on average, rebuild the hash * table to make it larger. */ @@ -104,8 +110,7 @@ const Tcl_HashKeyType tclStringHashKeyType = { void Tcl_InitHashTable( - Tcl_HashTable *tablePtr, - /* Pointer to table record, which is supplied + Tcl_HashTable *tablePtr, /* Pointer to table record, which is supplied * by the caller. */ int keyType) /* Type of keys to use in table: * TCL_STRING_KEYS, TCL_ONE_WORD_KEYS, or an @@ -142,8 +147,7 @@ Tcl_InitHashTable( void Tcl_InitCustomHashTable( - Tcl_HashTable *tablePtr, - /* Pointer to table record, which is supplied + Tcl_HashTable *tablePtr, /* Pointer to table record, which is supplied * by the caller. */ int keyType, /* Type of keys to use in table: * TCL_STRING_KEYS, TCL_ONE_WORD_KEYS, @@ -234,6 +238,8 @@ FindHashEntry( *---------------------------------------------------------------------- */ +#define TCL_HASH_FIND ((int *)-1) + static Tcl_HashEntry * CreateHashEntry( Tcl_HashTable *tablePtr, /* Table in which to lookup entry. */ @@ -284,7 +290,7 @@ CreateHashEntry( /* if keys pointers or values are equal */ if ((key == hPtr->key.oneWordValue) || compareKeysProc((void *) key, hPtr)) { - if (newPtr) { + if (newPtr && (newPtr != TCL_HASH_FIND)) { *newPtr = 0; } return hPtr; @@ -299,7 +305,7 @@ CreateHashEntry( /* if needle pointer equals content pointer or values equal */ if ((key == hPtr->key.string) || compareKeysProc((void *) key, hPtr)) { - if (newPtr) { + if (newPtr && (newPtr != TCL_HASH_FIND)) { *newPtr = 0; } return hPtr; @@ -313,7 +319,7 @@ CreateHashEntry( continue; } if (key == hPtr->key.oneWordValue) { - if (newPtr) { + if (newPtr && (newPtr != TCL_HASH_FIND)) { *newPtr = 0; } return hPtr; @@ -321,7 +327,8 @@ CreateHashEntry( } } - if (!newPtr) { + if (!newPtr || (newPtr == TCL_HASH_FIND)) { + /* This is the findProc functionality, so we are done. */ return NULL; } @@ -623,9 +630,9 @@ Tcl_HashStats( } else { overflow++; } - tmp = j; + tmp = (double)j; if (tablePtr->numEntries != 0) { - average += (tmp+1.0)*(tmp/tablePtr->numEntries)/2.0; + average += (tmp+1.0)*(tmp/(double)tablePtr->numEntries)/2.0; } } diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index f7fd5b0..c83410e 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -207,6 +207,17 @@ int TclGetAliasObj(Tcl_Interp *interp, const char *childCmd, } #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); +} + + #define TclBN_mp_add mp_add #define TclBN_mp_add_d mp_add_d #define TclBN_mp_and mp_and @@ -1241,7 +1252,7 @@ const TclStubs tclStubs = { 0, /* 419 */ 0, /* 420 */ 0, /* 421 */ - 0, /* 422 */ + Tcl_CreateHashEntry, /* 422 */ Tcl_InitCustomHashTable, /* 423 */ Tcl_InitObjHashTable, /* 424 */ Tcl_CommandTraceInfo, /* 425 */ -- cgit v0.12 From e4abfe81b8090089d58071624a4373390ac94bf2 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Tue, 13 May 2025 19:07:45 +0000 Subject: Bit more progress on test suite --- tests/listTypes.test | 235 ++++++++++++++++++++++++++++++++++++++++++++++----- 1 file changed, 215 insertions(+), 20 deletions(-) diff --git a/tests/listTypes.test b/tests/listTypes.test index d209293..df75bef 100644 --- a/tests/listTypes.test +++ b/tests/listTypes.test @@ -27,16 +27,16 @@ # - 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 # TODO - see comments to testlistobj # TODO - see listobjmemcheck and indexmemcheck in listObj.test -# TODO - lrepeat/lreverse string generation when starting with # +# TODO - lrepeat string generation when starting with # # TODO - lrepeat/lreverse list of braces -# TODO - nested lrepeat with index list and separate indices -# TODO - nested list combinations. Verify none of the lists shimmer -# TODO - [lreverse [lreverse]] should retrieve original list. if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 @@ -65,9 +65,9 @@ namespace eval listtype { # Compiled bytecode depends on whether arguments are literals or # variables. So test variations are needed for both. - variable zero 0 - variable minusOne -1 - variable ten 10 + 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. @@ -100,7 +100,9 @@ namespace eval listtype { # Convert the given list to non abstract proc makeNonAbstract {l} { - list {*}$l + set l [lmap v $l {set v}] + assertListType $l list + return $l } # Returns a list of length $largeListLength of the specified type @@ -138,8 +140,14 @@ namespace eval listtype { 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 + # 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 { @@ -347,13 +355,13 @@ namespace eval listtype { {0 -1 0} {} \ [list 0 $largeListLength 0] {} \ ] { - testdef ltype-lindex-nested-onearg-$ltype1-$ltype2-$ltype3 "lindex nested single indices argument $ltype1 $ltype2 $ltype3 $indices" \ + testdef lindex-nested-onearg-$ltype1-$ltype2-$ltype3 "lindex nested single indices argument $ltype1 $ltype2 $ltype3 $indices" \ -body { variable indices lindex [makeNestedList $ltype1 $ltype2 $ltype3] $indices } -result $result - testdef ltype-lindex-nested-multiarg-$ltype1-$ltype2-$ltype3 "lindex nested multiple index arguments $ltype1 $ltype2 $ltype3 $indices" \ + testdef lindex-nested-multiarg-$ltype1-$ltype2-$ltype3 "lindex nested multiple index arguments $ltype1 $ltype2 $ltype3 $indices" \ -body { variable indices lindex [makeNestedList $ltype1 $ltype2 $ltype3] {*}$indices @@ -593,11 +601,81 @@ namespace eval listtype { } ################################################################ - # lreverse tests - TBD - ################################################################ - # lsearch tests - TBD + # 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 - TBD + # 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 @@ -657,7 +735,6 @@ namespace eval listtype { } -result [list {*}[makeList $ltype] {*}[lrepeat [expr (7-$largeListLength%7)] {}]] } - ################################################################ # lmap tests # Aside from correct results, should not shimmer original @@ -682,19 +759,87 @@ namespace eval listtype { } - ################################################################ # lrange tests - TBD + ################################################################ - # concat tests - TBD + # 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 - TBD + # 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] ,] + } + ################################################################ # lrepeat tests - TBD ################################################################ - # lpop tests - TBD + # 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 + foreach ltype1 $nestableTypes { + foreach ltype2 $nestableTypes { + foreach ltype3 $listTypes { + lassign [getFirstAndLast $ltype3] first last + foreach indices [list {0 0 0} {3 3 3} {end end end} ] { + set index [lindex $indices 0] + set expected [makeNestedList $ltype1 $ltype2 $ltype3] + set elem [lindex $expected $indices] + set inner [lindex $expected [lrange $indices 0 1]] + set inner [lremove $inner $index] + lset expected [lrange $indices 0 1] $inner + testdef lpop-nested-$ltype1-$ltype2-$ltype3-[join $indices ,] \ + "lpop nested multiple index arguments $ltype1 $ltype2 $ltype3 $indices" \ + -body { + variable indices + set l [makeNestedList $ltype1 $ltype2 $ltype3] + list [lpop l {*}$indices] $l + } -result [list $elem $expected] + } + } + } + } ################################################################ # lremove tests @@ -754,6 +899,56 @@ namespace eval listtype { } -result [list 0 $expected $ltype [makeList $ltype]] } + ################################################################ + # lreverse tests + # + 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 lrepeat 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 lrepeat when first char is brace" -body { + set l [lreverse [lrepeat $largeListLength \{]] + list [getListType $l] $l + } -result [list reversedList [lreverse [makeNonAbstract [lrepeat $largeListLength \{]]]] + } # All done -- cgit v0.12 From e174970572e20a701fdac863658362c3b1e4f71a Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Wed, 14 May 2025 12:15:24 +0000 Subject: Complete list operation tests --- generic/tclListTypes.c | 1 - tests/listTypes.test | 107 +++++++++++++++++++++++++++++++++++++++++++------ 2 files changed, 95 insertions(+), 13 deletions(-) diff --git a/generic/tclListTypes.c b/generic/tclListTypes.c index 313be62..bbf80df 100644 --- a/generic/tclListTypes.c +++ b/generic/tclListTypes.c @@ -705,7 +705,6 @@ LrangeTypeIndex( Tcl_Obj **elemPtrPtr) /* Returned element */ { LrangeRep *repPtr = (LrangeRep *)objPtr->internalRep.otherValuePtr; - Tcl_Size len = repPtr->rangeLen; if (index < 0 || index >= repPtr->rangeLen) { *elemPtrPtr = NULL; return TCL_OK; diff --git a/tests/listTypes.test b/tests/listTypes.test index df75bef..f490ba7 100644 --- a/tests/listTypes.test +++ b/tests/listTypes.test @@ -35,8 +35,6 @@ # - generated string representations # TODO - see comments to testlistobj # TODO - see listobjmemcheck and indexmemcheck in listObj.test -# TODO - lrepeat string generation when starting with # -# TODO - lrepeat/lreverse list of braces if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 @@ -760,9 +758,6 @@ namespace eval listtype { } ################################################################ - # lrange tests - TBD - - ################################################################ # 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 @@ -791,9 +786,6 @@ namespace eval listtype { } ################################################################ - # lrepeat tests - TBD - - ################################################################ # lpop tests # Always shimmers to non-abstract list. foreach ltype $listTypes { @@ -821,6 +813,7 @@ namespace eval listtype { foreach ltype1 $nestableTypes { foreach ltype2 $nestableTypes { foreach ltype3 $listTypes { + continue; # XXX lassign [getFirstAndLast $ltype3] first last foreach indices [list {0 0 0} {3 3 3} {end end end} ] { set index [lindex $indices 0] @@ -902,6 +895,9 @@ namespace eval listtype { ################################################################ # 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 { @@ -938,17 +934,104 @@ namespace eval listtype { list [getListType $l] $l } -result [list list [doReverse [makeList list $smallListLength]]] - - testdef lreverse-hashchar "Verify string representation of lrepeat when first char is #" -body { + 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 lrepeat when first char is brace" -body { + 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 should always be non-abstract list" -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]] + } } # All done -- cgit v0.12 From 5f9fe4c7b379ab159cdd7999869d3a377b12372f Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 14 May 2025 12:19:40 +0000 Subject: Make the [lappend] command into one that handles expansion natively --- generic/tclBasic.c | 2 +- generic/tclCompCmdsGR.c | 63 +++++++++++++++++++++++++++++++++++++++++-------- 2 files changed, 54 insertions(+), 11 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 400755f..d7e22fd 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -334,7 +334,7 @@ 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}, {"lindex", Tcl_LindexObjCmd, TclCompileLindexCmd, NULL, CMD_IS_SAFE}, diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 7f1e917..522cd58 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -832,13 +832,13 @@ 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); - /* - * 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. - */ - if (numWords != 3 || !EnvHasLVT(envPtr)) { + if (numWords != 3) { goto lappendMultiple; } @@ -848,9 +848,25 @@ TclCompileLappendCmd( 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. @@ -882,19 +898,45 @@ TclCompileLappendCmd( lappendMultiple: /* - * Concatenate all our remaining arguments into a list. - * TODO: Turn this into an expand-handling list building sequence. + * 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; + int concat; + valueTokenPtr = TokenAfter(varTokenPtr); - for (i = 2 ; i < numWords ; i++) { + concat = build = 0; + 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++; + } valueTokenPtr = TokenAfter(valueTokenPtr); } - OP4( LIST, numWords - 2); + if (build > 0) { + OP4( LIST, build); + if (concat) { + OP( LIST_CONCAT); + } + } } /* @@ -902,6 +944,7 @@ TclCompileLappendCmd( * these opcodes handles all the special cases that [lappend] knows about. */ + lappendList: if (isScalar) { if (localIndex < 0) { OP( LAPPEND_LIST_STK); -- cgit v0.12 From 0e0fc46b35733aaf81fb3f7448441089cf0a6b8f Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 14 May 2025 13:19:00 +0000 Subject: remove TODO comment --- generic/tclCompCmdsGR.c | 1 - 1 file changed, 1 deletion(-) diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 522cd58..3bf1f60 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -818,7 +818,6 @@ TclCompileLappendCmd( int isScalar; Tcl_LVTIndex localIndex; - /* TODO: Consider support for compiling expanded args. */ if (numWords < 2 || numWords > UINT_MAX) { return TCL_ERROR; } -- cgit v0.12 From 300e6fafe8f92e3793ceb481b1f05d7da0e38cca Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Thu, 15 May 2025 05:59:26 +0000 Subject: Use internalRep.twoPtrValue.ptr1 and initialize .ptr2 to NULL instead of using otherValuePtr. Otherwise valgrind complains as Tcl_Representation accesses .ptr2 which is uninitialized. --- generic/tclListTypes.c | 21 ++++++++++++--------- 1 file changed, 12 insertions(+), 9 deletions(-) diff --git a/generic/tclListTypes.c b/generic/tclListTypes.c index bbf80df..2643728 100644 --- a/generic/tclListTypes.c +++ b/generic/tclListTypes.c @@ -582,7 +582,7 @@ Tcl_ListObjRepeat( * * 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 otherValuePtr field of the Tcl_Obj. + * The type is a descriptor stored in the twoPtrValue.ptr1 field of Tcl_Obj. * ------------------------------------------------------------------------ */ typedef struct LrangeRep { @@ -660,7 +660,8 @@ LrangeNew( repPtr->rangeLen = rangeLen; TclNewObj(resultPtr); TclInvalidateStringRep(resultPtr); - resultPtr->internalRep.otherValuePtr = repPtr; + resultPtr->internalRep.twoPtrValue.ptr1 = repPtr; + resultPtr->internalRep.twoPtrValue.ptr2 = NULL; resultPtr->typePtr = &lrangeType; *resultPtrPtr = resultPtr; return TCL_OK; @@ -670,7 +671,7 @@ LrangeNew( void LrangeFreeIntrep(Tcl_Obj *objPtr) { - LrangeRep *repPtr = (LrangeRep *)objPtr->internalRep.otherValuePtr; + LrangeRep *repPtr = (LrangeRep *)objPtr->internalRep.twoPtrValue.ptr1; if (repPtr->refCount <= 1) { Tcl_DecrRefCount(repPtr->srcListPtr); Tcl_Free(repPtr); @@ -682,9 +683,10 @@ LrangeFreeIntrep(Tcl_Obj *objPtr) void LrangeDupIntrep(Tcl_Obj *srcObj, Tcl_Obj *dupObj) { - LrangeRep *repPtr = (LrangeRep *)srcObj->internalRep.otherValuePtr; + LrangeRep *repPtr = (LrangeRep *)srcObj->internalRep.twoPtrValue.ptr1; repPtr->refCount++; - dupObj->internalRep.otherValuePtr = repPtr; + dupObj->internalRep.twoPtrValue.ptr1 = repPtr; + dupObj->internalRep.twoPtrValue.ptr2 = NULL; dupObj->typePtr = srcObj->typePtr; } @@ -692,7 +694,7 @@ LrangeDupIntrep(Tcl_Obj *srcObj, Tcl_Obj *dupObj) Tcl_Size LrangeTypeLength(Tcl_Obj *objPtr) { - LrangeRep *repPtr = (LrangeRep *)objPtr->internalRep.otherValuePtr; + LrangeRep *repPtr = (LrangeRep *)objPtr->internalRep.twoPtrValue.ptr1; return repPtr->rangeLen; } @@ -704,7 +706,7 @@ LrangeTypeIndex( Tcl_Size index, /* Element index */ Tcl_Obj **elemPtrPtr) /* Returned element */ { - LrangeRep *repPtr = (LrangeRep *)objPtr->internalRep.otherValuePtr; + LrangeRep *repPtr = (LrangeRep *)objPtr->internalRep.twoPtrValue.ptr1; if (index < 0 || index >= repPtr->rangeLen) { *elemPtrPtr = NULL; return TCL_OK; @@ -725,7 +727,7 @@ LrangeSlice( assert(objPtr->typePtr == &lrangeType); Tcl_Size rangeLen; - LrangeRep *repPtr = (LrangeRep *)objPtr->internalRep.otherValuePtr; + LrangeRep *repPtr = (LrangeRep *)objPtr->internalRep.twoPtrValue.ptr1; Tcl_Obj *sourcePtr = repPtr->srcListPtr; rangeLen = @@ -739,10 +741,11 @@ LrangeSlice( * If the original source list was also a lrangeType, we can reference * *its* source directly. Do this recursively until we reach a * non-lrangeType. + * TODO - this loop not needed! */ Tcl_Size newSrcIndex = start + repPtr->srcIndex; while (sourcePtr->typePtr == &lrangeType) { - LrangeRep *nextRepPtr = (LrangeRep *)sourcePtr->internalRep.otherValuePtr; + LrangeRep *nextRepPtr = (LrangeRep *)sourcePtr->internalRep.twoPtrValue.ptr1; newSrcIndex += nextRepPtr->srcIndex; sourcePtr = nextRepPtr->srcListPtr; } -- cgit v0.12 From e115aca98d0bf3147468b5efc4bcdf46415efd0e Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Thu, 15 May 2025 11:35:18 +0000 Subject: Add tests for memory leaks --- tests/listObj.test | 89 +-------------------- tests/listTypes.test | 214 ++++++++++++++++++++++++++++++++++++++++++++------- 2 files changed, 190 insertions(+), 113 deletions(-) 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/listTypes.test b/tests/listTypes.test index f490ba7..8722053 100644 --- a/tests/listTypes.test +++ b/tests/listTypes.test @@ -33,8 +33,6 @@ # For the abstract list types not tested elsewhere, # - verify constructor commands return the expected type # - generated string representations -# TODO - see comments to testlistobj -# TODO - see listobjmemcheck and indexmemcheck in listObj.test if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 @@ -43,9 +41,11 @@ if {"::tcltest" ni [namespace children]} { ::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} @@ -239,11 +239,9 @@ namespace eval listtype { } else { set body $comment } - dict lappend args -constraints testobj - set cleanup [dict getwithdefault $args -cleanup {}] - dict unset args -cleanup - append cleanup "\nunset -nocomplain l l1 l2 l3 a b c d e f g" + 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] \ @@ -269,7 +267,7 @@ namespace eval listtype { 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 -cleanup $cleanup \ + -body testxproc \ {*}$args] } @@ -369,6 +367,23 @@ namespace eval listtype { } } + # 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 @@ -810,26 +825,24 @@ namespace eval listtype { } # lpop - nested indices + # Only two levels. Three levels takes too long with memdbg or valgrind foreach ltype1 $nestableTypes { - foreach ltype2 $nestableTypes { - foreach ltype3 $listTypes { - continue; # XXX - lassign [getFirstAndLast $ltype3] first last - foreach indices [list {0 0 0} {3 3 3} {end end end} ] { - set index [lindex $indices 0] - set expected [makeNestedList $ltype1 $ltype2 $ltype3] - set elem [lindex $expected $indices] - set inner [lindex $expected [lrange $indices 0 1]] - set inner [lremove $inner $index] - lset expected [lrange $indices 0 1] $inner - testdef lpop-nested-$ltype1-$ltype2-$ltype3-[join $indices ,] \ - "lpop nested multiple index arguments $ltype1 $ltype2 $ltype3 $indices" \ - -body { - variable indices - set l [makeNestedList $ltype1 $ltype2 $ltype3] - list [lpop l {*}$indices] $l - } -result [list $elem $expected] - } + 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] } } } @@ -1032,7 +1045,154 @@ namespace eval listtype { [expr {$ltype eq "arithseries" ? "arithseries" : "list"}] \ [lrange [getNonAbstract $ltype] 1 10]] } + + ################################################################ + # 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 memory + } -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 memory + } -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 memory + } -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 memory + } -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 memory + } -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 memory + } -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 memory + } -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 memory + } -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 memory + } -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 memory + } -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 memory + } -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 memory + } -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 {}} + + } # All done -::tcltest::cleanupTests +::tcltest::cleanupTests -- cgit v0.12 From e45ea653756d323237c9c8ae41cf34472f26d6f8 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 15 May 2025 11:52:55 +0000 Subject: Something changed in the Github CI environment. Does this fix filename-16.14 testcase? --- tests/fileName.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/fileName.test b/tests/fileName.test index af295f0..64213c7 100644 --- a/tests/fileName.test +++ b/tests/fileName.test @@ -1443,7 +1443,7 @@ test filename-16.13 {windows specific globbing} {win sharedCdrive} { cd //[info hostname]/c glob "\\\\\\\\[info hostname]\\\\c\\\\*Test" } //[info hostname]/c/globTest -test filename-16.14 {windows specific globbing} {win} { +test filename-16.14 {windows specific globbing} {win sharedCdrive} { cd [lindex [glob -types d -dir C:/ *] 0] expr {".." in [glob {{.,*}*}]} } {1} -- cgit v0.12 From c6d1381fb4da6cc4109f7172f76a33a1987a040f Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 15 May 2025 13:03:11 +0000 Subject: Drop reference counts on duplicated objects on error: DICT_PUT and DICT_REMOVE --- generic/tclExecute.c | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 86c7087..b578b01 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -7119,6 +7119,9 @@ TEBCresume( dictPtr = Tcl_DuplicateObj(dictPtr); } if (Tcl_DictObjPut(interp, dictPtr, OBJ_UNDER_TOS, OBJ_AT_TOS) != TCL_OK) { + if (allocateDict) { + Tcl_BounceRefCount(dictPtr); + } TRACE_ERROR(interp); goto gotError; } @@ -7138,6 +7141,9 @@ TEBCresume( dictPtr = Tcl_DuplicateObj(dictPtr); } if (Tcl_DictObjRemove(interp, dictPtr, OBJ_AT_TOS) != TCL_OK) { + if (allocateDict) { + Tcl_BounceRefCount(dictPtr); + } TRACE_ERROR(interp); goto gotError; } -- cgit v0.12 From 9ded4a5c191fe25f3c5cf491d8662c0cf94af600 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 15 May 2025 13:15:09 +0000 Subject: Need to test _MSVC_VER to see if we're in 19.0 or later to enable [[deprecated]] --- generic/tclCompile.h | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 202d8f0..f006334 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -603,9 +603,10 @@ typedef struct ByteCode { #elif defined(ALLOW_DEPRECATED_OPCODES) #define DEPRECATED_OPCODE(name) \ name -#elif defined(_MSC_VER) +#elif defined(_MSC_VER) && (_MSC_VER >= 1900) +// This is actually the C++17 and C23 standard form #define DEPRECATED_OPCODE(name) \ - name [[deprecated]] + name [[deprecated("use 4-byte operand version instead")]] #elif defined(__GNUC__) || defined(__clang__) #define DEPRECATED_OPCODE(name) \ name __attribute__((deprecated ("use 4-byte operand version instead"))) -- cgit v0.12 From 944bea7be8b7720580ba2c9a638e7558ec1f824d Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 15 May 2025 15:01:15 +0000 Subject: Minor optimisation in light of TIP 717 --- generic/tclCompCmdsSZ.c | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index f5fbd2c..6d14873 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -2591,12 +2591,11 @@ DupJumptableNumInfo( JumptableNumInfo *newJtnPtr = AllocJumptableNum(); Tcl_HashEntry *hPtr, *newHPtr; Tcl_HashSearch search; - int isNew; hPtr = Tcl_FirstHashEntry(&jtnPtr->hashTable, &search); for (; hPtr ; hPtr = Tcl_NextHashEntry(&search)) { newHPtr = Tcl_CreateHashEntry(&newJtnPtr->hashTable, - Tcl_GetHashKey(&jtnPtr->hashTable, hPtr), &isNew); + Tcl_GetHashKey(&jtnPtr->hashTable, hPtr), NULL); Tcl_SetHashValue(newHPtr, Tcl_GetHashValue(hPtr)); } return newJtnPtr; -- cgit v0.12 From 770dd633db2ec8992cc6e56fc99deae3cad8ccb8 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 15 May 2025 15:10:38 +0000 Subject: Actually, standards-compliant compilers should use the standard form for deprecation --- generic/tclCompile.h | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclCompile.h b/generic/tclCompile.h index f006334..4158336 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -603,8 +603,8 @@ typedef struct ByteCode { #elif defined(ALLOW_DEPRECATED_OPCODES) #define DEPRECATED_OPCODE(name) \ name -#elif defined(_MSC_VER) && (_MSC_VER >= 1900) -// This is actually the C++17 and C23 standard form +#elif (defined(__STDC_VERSION__) && __STDC_VERSION__ >= 202311L) \ + || (defined(_MSC_VER) && (_MSC_VER >= 1900)) #define DEPRECATED_OPCODE(name) \ name [[deprecated("use 4-byte operand version instead")]] #elif defined(__GNUC__) || defined(__clang__) -- cgit v0.12 From 1dc49da1cbc15882a4ff1618539372a041a3a50e Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Thu, 15 May 2025 15:39:40 +0000 Subject: Minor cleanup --- generic/tclListTypes.c | 40 +++++++++++++++------------------------- 1 file changed, 15 insertions(+), 25 deletions(-) diff --git a/generic/tclListTypes.c b/generic/tclListTypes.c index 2643728..f6c43d3 100644 --- a/generic/tclListTypes.c +++ b/generic/tclListTypes.c @@ -90,7 +90,7 @@ TclObjArrayElems(TclObjArray *arrayPtr, Tcl_Obj ***objPtrPtr) return arrayPtr->nelems; } -/* TODO - move to tclInt.h and use in other list implementations as well */ +/* 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) { @@ -240,9 +240,9 @@ static const Tcl_ObjType lreverseType = { NULL, /* sliceProc */ LreverseTypeReverse, /* reverseProc */ NULL, /* getElementsProc */ - NULL, /* setElementProc - TODO */ - NULL, /* replaceProc - TODO */ - NULL) /* inOperProc - TODO */ + NULL, /* setElementProc - FUTURES */ + NULL, /* replaceProc - FUTURES */ + NULL) /* inOperProc - FUTURES */ }; void @@ -424,7 +424,7 @@ static const Tcl_ObjType lrepeatType = { NULL, /* getElementsProc */ NULL, /* Must be NULL - see above comment */ NULL, /* Must be NULL - see above comment */ - NULL) /* inOperProc - TODO */ + NULL) /* inOperProc - FUTURES */ }; void @@ -617,7 +617,7 @@ static const Tcl_ObjType lrangeType = { NULL, /* getElementsProc */ NULL, /* setElementProc, see above comment */ NULL, /* replaceProc, see above comment */ - NULL) /* inOperProc - TODO */ + NULL) /* inOperProc - FUTURES */ }; static inline int @@ -738,38 +738,28 @@ LrangeSlice( } /* - * If the original source list was also a lrangeType, we can reference - * *its* source directly. Do this recursively until we reach a - * non-lrangeType. - * TODO - this loop not needed! + * Because of how ranges are constructed, they are never recursive. + * Not that the code below cares... */ + CLANG_ASSERT(sourcePtr->typePtr != &lrangeType); + + Tcl_Size sourceLen; Tcl_Size newSrcIndex = start + repPtr->srcIndex; - while (sourcePtr->typePtr == &lrangeType) { - LrangeRep *nextRepPtr = (LrangeRep *)sourcePtr->internalRep.twoPtrValue.ptr1; - newSrcIndex += nextRepPtr->srcIndex; - sourcePtr = nextRepPtr->srcListPtr; + 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. - * Note it is possible that sourcePtr is repPtr->srcListPtr if the range - * target is not itself a range. */ - Tcl_Size sourceLen; - if (TclListObjLength(interp, sourcePtr, &sourceLen) != TCL_OK) { - /* Cannot fail because how rangeType's are constructed but ... */ - return TCL_ERROR; - } /* * A range is always smaller than its source thus the following must * hold even for recursive ranges. - * TODO - change to an assert() */ - if ((newSrcIndex+rangeLen) > sourceLen) { - Tcl_Panic("lrangeType: (newSrcIndec+rangeLen) > sourceLen"); - } + CLANG_ASSERT((newSrcIndex + rangeLen) > sourceLen); /* * We will only use the lrangeType abstract list if the following -- cgit v0.12 From 3c66bcb7351133fb03aab98a1d1e577c45a6b5c7 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Thu, 15 May 2025 15:56:48 +0000 Subject: Oops, CLANG_ASSERT->assert --- generic/tclListTypes.c | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/generic/tclListTypes.c b/generic/tclListTypes.c index f6c43d3..5c71d35 100644 --- a/generic/tclListTypes.c +++ b/generic/tclListTypes.c @@ -372,7 +372,7 @@ Tcl_ListObjReverse( ListRep listRep; ListObjGetRep(resultPtr, &listRep); dataArray = ListRepElementsBase(&listRep); - CLANG_ASSERT(dataArray); + assert(dataArray); listRep.storePtr->numUsed = elemc; if (listRep.spanPtr) { /* Future proofing in case Tcl_NewListObj returns a span */ @@ -556,7 +556,7 @@ Tcl_ListObjRepeat( * number of times. */ - CLANG_ASSERT(dataArray || totalElems == 0 ); + assert(dataArray || totalElems == 0 ); if (objc == 1) { Tcl_Obj *tmpPtr = objv[0]; @@ -741,7 +741,7 @@ LrangeSlice( * Because of how ranges are constructed, they are never recursive. * Not that the code below cares... */ - CLANG_ASSERT(sourcePtr->typePtr != &lrangeType); + assert(sourcePtr->typePtr != &lrangeType); Tcl_Size sourceLen; Tcl_Size newSrcIndex = start + repPtr->srcIndex; @@ -759,7 +759,7 @@ LrangeSlice( * A range is always smaller than its source thus the following must * hold even for recursive ranges. */ - CLANG_ASSERT((newSrcIndex + rangeLen) > sourceLen); + assert((newSrcIndex + rangeLen) <= sourceLen); /* * We will only use the lrangeType abstract list if the following -- cgit v0.12 From 2607730ae3201cb8f0f7fde81307d988445a9bf3 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 16 May 2025 09:51:46 +0000 Subject: Fix TEBC internal operand signedness/width --- generic/tclExecute.c | 450 +++++++++++++++++++++++++-------------------------- 1 file changed, 225 insertions(+), 225 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 8f48df7..b5f3343 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -2039,8 +2039,9 @@ 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; + unsigned opnd; + int pcAdjustment, encIndex; Var *varPtr, *arrayPtr; #ifdef TCL_COMPILE_DEBUG char cmdNameBuf[21]; @@ -2271,7 +2272,7 @@ TEBCresume( if (inst == INST_LOAD_SCALAR1) { goto instLoadScalar1; } else if (inst == INST_PUSH1) { - PUSH_OBJECT(codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)]); + PUSH_OBJECT(codePtr->objArrayPtr[TclGetUInt1AtPtr(pc + 1)]); TRACE_WITH_OBJ(("%u => ", TclGetUInt1AtPtr(pc + 1)), OBJ_AT_TOS); inst = *(pc += 2); goto peepholeStart; @@ -2304,8 +2305,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. @@ -2467,10 +2468,10 @@ TEBCresume( case INST_TAILCALL: { Tcl_Obj *listPtr; - opnd = TclGetUInt1AtPtr(pc+1); + opnd = TclGetUInt1AtPtr(pc + 1); if (!(iPtr->varFramePtr->isProcCallFrame & 1)) { - TRACE(("%d => ERROR: tailcall in non-proc context\n", opnd)); + TRACE(("%u => ERROR: tailcall in non-proc context\n", opnd)); Tcl_SetObjResult(interp, Tcl_NewStringObj( "tailcall can only be called from a proc or lambda", -1)); DECACHE_STACK_INFO(); @@ -2482,9 +2483,9 @@ TEBCresume( #ifdef TCL_COMPILE_DEBUG /* FIXME: What is the right thing to trace? */ { - int i; + unsigned i; - TRACE(("%d [", opnd)); + TRACE(("%u [", opnd)); for (i=opnd-1 ; i>=0 ; i--) { TRACE_APPEND(("\"%.30s\"", O2S(OBJ_AT_DEPTH(i)))); if (i > 0) { @@ -2544,8 +2545,8 @@ TEBCresume( goto abnormalReturn; case INST_PUSH4: - objResultPtr = codePtr->objArrayPtr[TclGetUInt4AtPtr(pc+1)]; - TRACE_WITH_OBJ(("%u => ", TclGetUInt4AtPtr(pc+1)), objResultPtr); + objResultPtr = codePtr->objArrayPtr[TclGetUInt4AtPtr(pc + 1)]; + TRACE_WITH_OBJ(("%u => ", TclGetUInt4AtPtr(pc + 1)), objResultPtr); NEXT_INST_F(5, 0, 1); break; @@ -2563,7 +2564,7 @@ TEBCresume( break; case INST_OVER: - opnd = TclGetUInt4AtPtr(pc+1); + opnd = TclGetUInt4AtPtr(pc + 1); objResultPtr = OBJ_AT_DEPTH(opnd); TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); NEXT_INST_F(5, 0, 1); @@ -2588,8 +2589,7 @@ TEBCresume( break; case INST_STR_CONCAT1: - - opnd = TclGetUInt1AtPtr(pc+1); + opnd = TclGetUInt1AtPtr(pc + 1); DECACHE_STACK_INFO(); objResultPtr = TclStringCat(interp, opnd, &OBJ_AT_DEPTH(opnd-1), TCL_STRING_IN_PLACE); @@ -2610,7 +2610,7 @@ TEBCresume( * and then decrement their ref counts. */ - opnd = TclGetUInt4AtPtr(pc+1); + 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); @@ -2769,12 +2769,12 @@ TEBCresume( break; case INST_INVOKE_STK4: - objc = TclGetUInt4AtPtr(pc+1); + objc = TclGetUInt4AtPtr(pc + 1); pcAdjustment = 5; goto doInvocation; case INST_INVOKE_STK1: - objc = TclGetUInt1AtPtr(pc+1); + objc = TclGetUInt1AtPtr(pc + 1); pcAdjustment = 2; doInvocation: @@ -2827,14 +2827,14 @@ TEBCresume( } case INST_INVOKE_REPLACE: - objc = TclGetUInt4AtPtr(pc+1); - opnd = TclGetUInt1AtPtr(pc+5); + objc = TclGetUInt4AtPtr(pc + 1); + opnd = TclGetUInt1AtPtr(pc + 5); objPtr = POP_OBJECT(); objv = &OBJ_AT_DEPTH(objc-1); cleanup = objc; #ifdef TCL_COMPILE_DEBUG if (tclTraceExec >= 2) { - Tcl_Size i; + unsigned i; if (traceInstructions) { strncpy(cmdNameBuf, TclGetString(objv[0]), 20); @@ -2899,12 +2899,12 @@ TEBCresume( case INST_LOAD_SCALAR1: instLoadScalar1: - opnd = TclGetUInt1AtPtr(pc+1); - varPtr = LOCAL(opnd); + 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. @@ -2921,12 +2921,12 @@ TEBCresume( goto doCallPtrGetVar; case INST_LOAD_SCALAR4: - 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)) { /* * No errors, no traces: just get the value. @@ -2943,22 +2943,22 @@ TEBCresume( goto doCallPtrGetVar; case INST_LOAD_ARRAY4: - opnd = TclGetUInt4AtPtr(pc+1); + varIdx = TclGetUInt4AtPtr(pc + 1); pcAdjustment = 5; goto doLoadArray; case INST_LOAD_ARRAY1: - opnd = TclGetUInt1AtPtr(pc+1); + varIdx = TclGetUInt1AtPtr(pc + 1); pcAdjustment = 2; doLoadArray: 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)) { @@ -2972,7 +2972,7 @@ TEBCresume( } } 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; @@ -3014,7 +3014,7 @@ TEBCresume( NEXT_INST_V(1, cleanup, 1); } pcAdjustment = 1; - opnd = -1; + varIdx = -1; doCallPtrGetVar: /* @@ -3024,7 +3024,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 (!objResultPtr) { TRACE_ERROR(interp); @@ -3048,19 +3048,19 @@ TEBCresume( Tcl_Size len; case INST_STORE_ARRAY4: - opnd = TclGetUInt4AtPtr(pc+1); + varIdx = TclGetUInt4AtPtr(pc + 1); pcAdjustment = 5; goto doStoreArrayDirect; case INST_STORE_ARRAY1: - opnd = TclGetUInt1AtPtr(pc+1); + varIdx = TclGetUInt1AtPtr(pc + 1); pcAdjustment = 2; doStoreArrayDirect: 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; @@ -3080,18 +3080,18 @@ TEBCresume( goto doStoreArrayDirectFailed; case INST_STORE_SCALAR4: - opnd = TclGetUInt4AtPtr(pc+1); + varIdx = TclGetUInt4AtPtr(pc + 1); pcAdjustment = 5; goto doStoreScalarDirect; case INST_STORE_SCALAR1: - opnd = TclGetUInt1AtPtr(pc+1); + varIdx = TclGetUInt1AtPtr(pc + 1); pcAdjustment = 2; doStoreScalarDirect: 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; } @@ -3182,31 +3182,31 @@ TEBCresume( } cleanup = ((part2Ptr == NULL)? 2 : 3); pcAdjustment = 1; - opnd = -1; + varIdx = -1; goto doCallPtrSetVar; case INST_LAPPEND_ARRAY4: - opnd = TclGetUInt4AtPtr(pc+1); + varIdx = TclGetUInt4AtPtr(pc + 1); pcAdjustment = 5; storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE | TCL_LIST_ELEMENT); goto doStoreArray; case INST_LAPPEND_ARRAY1: - opnd = TclGetUInt1AtPtr(pc+1); + varIdx = TclGetUInt1AtPtr(pc + 1); pcAdjustment = 2; storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE | TCL_LIST_ELEMENT); goto doStoreArray; case INST_APPEND_ARRAY4: - opnd = TclGetUInt4AtPtr(pc+1); + varIdx = TclGetUInt4AtPtr(pc + 1); pcAdjustment = 5; storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); goto doStoreArray; case INST_APPEND_ARRAY1: - opnd = TclGetUInt1AtPtr(pc+1); + varIdx = TclGetUInt1AtPtr(pc + 1); pcAdjustment = 2; storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); goto doStoreArray; @@ -3214,8 +3214,8 @@ TEBCresume( 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,7 +3225,7 @@ 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; @@ -3233,35 +3233,35 @@ TEBCresume( goto doCallPtrSetVar; case INST_LAPPEND_SCALAR4: - opnd = TclGetUInt4AtPtr(pc+1); + varIdx = TclGetUInt4AtPtr(pc + 1); pcAdjustment = 5; storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE | TCL_LIST_ELEMENT); goto doStoreScalar; case INST_LAPPEND_SCALAR1: - opnd = TclGetUInt1AtPtr(pc+1); + varIdx = TclGetUInt1AtPtr(pc + 1); pcAdjustment = 2; storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE | TCL_LIST_ELEMENT); goto doStoreScalar; case INST_APPEND_SCALAR4: - opnd = TclGetUInt4AtPtr(pc+1); + varIdx = TclGetUInt4AtPtr(pc + 1); pcAdjustment = 5; storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); goto doStoreScalar; case INST_APPEND_SCALAR1: - opnd = TclGetUInt1AtPtr(pc+1); + varIdx = TclGetUInt1AtPtr(pc + 1); pcAdjustment = 2; storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); goto doStoreScalar; doStoreScalar: valuePtr = OBJ_AT_TOS; - varPtr = LOCAL(opnd); - TRACE(("%u <- \"%.30s\" => ", opnd, O2S(valuePtr))); + varPtr = LOCAL(varIdx); + TRACE(("%u <- \"%.30s\" => ", (unsigned) varIdx, O2S(valuePtr))); while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } @@ -3272,7 +3272,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); @@ -3287,15 +3287,15 @@ TEBCresume( 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); @@ -3310,18 +3310,18 @@ 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); @@ -3336,7 +3336,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; @@ -3384,7 +3384,7 @@ TEBCresume( NEXT_INST_V(pcAdjustment, cleanup, 1); lappendList: - opnd = -1; + varIdx = -1; if (TclListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK) { TRACE_ERROR(interp); @@ -3408,7 +3408,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)--; @@ -3443,7 +3443,7 @@ TEBCresume( } 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: @@ -3477,7 +3477,7 @@ TEBCresume( 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) { case INST_INCR_SCALAR1: @@ -3512,7 +3512,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) { @@ -3528,8 +3528,8 @@ TEBCresume( goto doIncrVar; case INST_INCR_ARRAY1_IMM: - opnd = TclGetUInt1AtPtr(pc+1); - increment = TclGetInt1AtPtr(pc+2); + varIdx = TclGetUInt1AtPtr(pc + 1); + increment = TclGetInt1AtPtr(pc + 2); TclNewIntObj(incrPtr, increment); Tcl_IncrRefCount(incrPtr); pcAdjustment = 3; @@ -3537,14 +3537,15 @@ TEBCresume( 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); @@ -3553,11 +3554,11 @@ TEBCresume( goto doIncrVar; case INST_INCR_SCALAR1_IMM: - opnd = TclGetUInt1AtPtr(pc+1); - increment = TclGetInt1AtPtr(pc+2); + varIdx = TclGetUInt1AtPtr(pc + 1); + increment = TclGetInt1AtPtr(pc + 2); pcAdjustment = 3; cleanup = 0; - varPtr = LOCAL(opnd); + varPtr = LOCAL(varIdx); while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } @@ -3579,7 +3580,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 +3594,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 +3639,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 +3668,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) { @@ -3694,16 +3695,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 +3716,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 +3730,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 +3797,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 @@ -3822,22 +3823,22 @@ TEBCresume( 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); 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); @@ -3869,20 +3870,20 @@ TEBCresume( 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); 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 +3892,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 */ @@ -3924,20 +3925,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; @@ -3968,7 +3969,7 @@ TEBCresume( DECACHE_STACK_INFO(); resPtr = TclPtrSetVarIdx(interp, varPtr, arrayPtr, part1Ptr, NULL, - objPtr, TCL_LEAVE_ERR_MSG, opnd); + objPtr, TCL_LEAVE_ERR_MSG, varIdx); CACHE_STACK_INFO(); if (resPtr == NULL) { TRACE_ERROR(interp); @@ -3980,7 +3981,7 @@ TEBCresume( NEXT_INST_V(pcAdjustment, cleanup, 0); constError: - TclObjVarErrMsg(interp, part1Ptr, NULL, "make constant", msgPart, opnd); + TclObjVarErrMsg(interp, part1Ptr, NULL, "make constant", msgPart, varIdx); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CONST", (char *)NULL); TRACE_ERROR(interp); goto gotError; @@ -3993,19 +3994,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 +4015,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); @@ -4029,19 +4030,19 @@ TEBCresume( 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 +4061,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 +4090,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 +4115,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 +4139,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 +4162,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)) { @@ -4189,7 +4190,7 @@ TEBCresume( VarHashRefCount(otherPtr)++; } } else if (TclPtrObjMakeUpvarIdx(interp, otherPtr, NULL, 0, - opnd) != TCL_OK) { + varIdx) != TCL_OK) { TRACE_ERROR(interp); goto gotError; } @@ -4210,17 +4211,17 @@ TEBCresume( */ case INST_JUMP1: - opnd = TclGetInt1AtPtr(pc+1); - TRACE(("%d => new pc %" TCL_Z_MODIFIER "u\n", opnd, - (size_t)(pc + opnd - codePtr->codeStart))); + pcAdjustment = TclGetInt1AtPtr(pc + 1); + TRACE(("%d => new pc %" TCL_Z_MODIFIER "u\n", pcAdjustment, + (size_t)(pc + pcAdjustment - 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, - (pc + opnd - codePtr->codeStart))); - NEXT_INST_F(opnd, 0, 0); + pcAdjustment = TclGetInt4AtPtr(pc + 1); + TRACE(("%d => new pc %" TCL_Z_MODIFIER "u\n", pcAdjustment, + (pc + pcAdjustment - codePtr->codeStart))); + NEXT_INST_F(pcAdjustment, 0, 0); { int jmpOffset[2], b; @@ -4228,23 +4229,23 @@ TEBCresume( /* 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[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); + jmpOffset[1] = TclGetInt4AtPtr(pc + 1); goto doCondJump; case INST_JUMP_FALSE1: - jmpOffset[0] = TclGetInt1AtPtr(pc+1); + jmpOffset[0] = TclGetInt1AtPtr(pc + 1); jmpOffset[1] = 2; goto doCondJump; case INST_JUMP_TRUE1: jmpOffset[0] = 2; - jmpOffset[1] = TclGetInt1AtPtr(pc+1); + jmpOffset[1] = TclGetInt1AtPtr(pc + 1); doCondJump: valuePtr = OBJ_AT_TOS; @@ -4288,7 +4289,7 @@ TEBCresume( * instr if lookup fails. */ - opnd = TclGetInt4AtPtr(pc+1); + opnd = TclGetUInt4AtPtr(pc + 1); jtPtr = (JumptableInfo *) codePtr->auxDataArrayPtr[opnd].clientData; TRACE(("%d \"%.20s\" => ", opnd, O2S(OBJ_AT_TOS))); hPtr = Tcl_FindHashEntry(&jtPtr->hashTable, TclGetString(OBJ_AT_TOS)); @@ -4439,12 +4440,12 @@ TEBCresume( NEXT_INST_F(1, 0, 1); case INST_TCLOO_NEXT_CLASS: - opnd = TclGetUInt1AtPtr(pc+1); + opnd = TclGetUInt1AtPtr(pc + 1); framePtr = iPtr->varFramePtr; valuePtr = OBJ_AT_DEPTH(opnd - 2); objv = &OBJ_AT_DEPTH(opnd - 1); skip = 2; - TRACE(("%d => ", opnd)); + TRACE(("%u => ", opnd)); if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { TRACE_APPEND(("ERROR: no TclOO call context\n")); @@ -4485,6 +4486,7 @@ TEBCresume( newDepth = i; #ifdef TCL_COMPILE_DEBUG if (tclTraceExec >= 2) { + unsigned j; if (traceInstructions) { strncpy(cmdNameBuf, TclGetString(objv[0]), 20); } else { @@ -4492,8 +4494,8 @@ TEBCresume( iPtr->numLevels, (pc - codePtr->codeStart)); } - for (i = 0; i < opnd; i++) { - TclPrintObject(stdout, objv[i], 15); + for (j = 0; j < opnd; j++) { + TclPrintObject(stdout, objv[j], 15); fprintf(stdout, " "); } fprintf(stdout, "\n"); @@ -4538,11 +4540,11 @@ TEBCresume( } case INST_TCLOO_NEXT: - opnd = TclGetUInt1AtPtr(pc+1); + opnd = TclGetUInt1AtPtr(pc + 1); objv = &OBJ_AT_DEPTH(opnd - 1); framePtr = iPtr->varFramePtr; skip = 1; - TRACE(("%d => ", opnd)); + TRACE(("%u => ", opnd)); if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { TRACE_APPEND(("ERROR: no TclOO call context\n")); @@ -4584,7 +4586,7 @@ TEBCresume( goto gotError; #ifdef TCL_COMPILE_DEBUG } else if (tclTraceExec >= 2) { - int i; + unsigned i; if (traceInstructions) { strncpy(cmdNameBuf, TclGetString(objv[0]), 20); @@ -4681,8 +4683,8 @@ TEBCresume( */ { - int numIndices, nocase, match, cflags; - Tcl_Size slength, length2, fromIdx, toIdx, index, s1len, s2len; + int nocase, match, cflags, fromIdxEnc, toIdxEnc; + Tcl_Size slength, length2, fromIdx, toIdx, index, s1len, s2len, numIndices; const char *s1, *s2; case INST_LIST: @@ -4691,7 +4693,7 @@ TEBCresume( * decrement their ref counts. */ - opnd = TclGetUInt4AtPtr(pc+1); + 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); @@ -4790,8 +4792,8 @@ TEBCresume( */ valuePtr = OBJ_AT_TOS; - opnd = TclGetInt4AtPtr(pc+1); - TRACE(("\"%.30s\" %d => ", O2S(valuePtr), opnd)); + 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,7 +4805,7 @@ 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 */ @@ -4830,7 +4832,7 @@ TEBCresume( /* Decode end-offset index values. */ - index = TclIndexDecode(opnd, objc - 1); + index = TclIndexDecode(encIndex, objc - 1); pcAdjustment = 5; lindexFastPath: @@ -4841,7 +4843,6 @@ TEBCresume( } lindexFastPath2: - TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); NEXT_INST_F(pcAdjustment, 1, 1); @@ -4850,14 +4851,14 @@ TEBCresume( * Determine the count of index args. */ - opnd = TclGetUInt4AtPtr(pc+1); - numIndices = opnd-1; + opnd = TclGetUInt4AtPtr(pc + 1); + numIndices = opnd - 1; /* * Do the 'lindex' operation. */ - TRACE(("%d => ", opnd)); + TRACE(("%u => ", opnd)); objResultPtr = TclLindexFlat(interp, OBJ_AT_DEPTH(numIndices), numIndices, &OBJ_AT_DEPTH(numIndices - 1)); if (!objResultPtr) { @@ -4879,7 +4880,7 @@ TEBCresume( opnd = TclGetUInt4AtPtr(pc + 1); numIndices = opnd - 2; - TRACE(("%d => ", opnd)); + TRACE(("%u => ", opnd)); /* * Get the old value of variable, and remove the stack ref. This is @@ -4962,10 +4963,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 @@ -5000,13 +5000,13 @@ TEBCresume( /* Decode index value operands. */ - if (toIdx == TCL_INDEX_NONE) { + if (toIdxEnc == -1) { emptyList: TclNewObj(objResultPtr); TRACE_APPEND(("\"%.30s\"", O2S(objResultPtr))); NEXT_INST_F(9, 1, 1); } - toIdx = TclIndexDecode((int)toIdx, objc - 1); + toIdx = TclIndexDecode(toIdxEnc, objc - 1); if (toIdx == TCL_INDEX_NONE) { goto emptyList; } else if (toIdx >= objc) { @@ -5015,15 +5015,15 @@ 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((int)fromIdx, objc - 1); + fromIdx = TclIndexDecode(fromIdxEnc, objc - 1); DECACHE_STACK_INFO(); if (TclObjTypeHasProc(valuePtr, sliceProc)) { @@ -5145,7 +5145,7 @@ TEBCresume( int end_indicator; int haveSecondIndex, flags; Tcl_Obj *fromIdxObj, *toIdxObj; - opnd = TclGetInt4AtPtr(pc + 1); + opnd = TclGetUInt4AtPtr(pc + 1); flags = TclGetInt1AtPtr(pc + 5); /* Stack: ... listobj index1 ?index2? new1 ... newN */ @@ -5416,10 +5416,10 @@ TEBCresume( 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) { @@ -5429,8 +5429,8 @@ TEBCresume( /* Decode index operands. */ - toIdx = TclIndexDecode((int)toIdx, slength - 1); - fromIdx = TclIndexDecode((int)fromIdx, slength - 1); + toIdx = TclIndexDecode(toIdxEnc, slength - 1); + fromIdx = TclIndexDecode(fromIdxEnc, slength - 1); if (toIdx == TCL_INDEX_NONE) { TclNewObj(objResultPtr); } else { @@ -5576,7 +5576,7 @@ TEBCresume( NEXT_INST_F(1, 2, 1); case INST_STR_CLASS: - opnd = TclGetInt1AtPtr(pc+1); + opnd = TclGetUInt1AtPtr(pc + 1); valuePtr = OBJ_AT_TOS; TRACE(("%s \"%.30s\" => ", tclStringClassTable[opnd].name, O2S(valuePtr))); @@ -5598,7 +5598,7 @@ TEBCresume( } case INST_STR_MATCH: - nocase = TclGetInt1AtPtr(pc+1); + nocase = TclGetInt1AtPtr(pc + 1); valuePtr = OBJ_AT_TOS; /* String */ value2Ptr = OBJ_UNDER_TOS; /* Pattern */ @@ -6462,7 +6462,7 @@ TEBCresume( * corresponding Tcl_Objs to the stack. */ - opnd = TclGetUInt4AtPtr(pc+1); + opnd = TclGetUInt4AtPtr(pc + 1); infoPtr = (ForeachInfo *)codePtr->auxDataArrayPtr[opnd].clientData; numLists = infoPtr->numLists; TRACE(("%u => ", opnd)); @@ -6684,7 +6684,7 @@ 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), + TclGetUInt4AtPtr(pc + 1), (catchTop - initCatchTop - 1), CURR_DEPTH)); NEXT_INST_F(5, 0, 0); break; @@ -6749,7 +6749,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; @@ -6773,7 +6773,7 @@ TEBCresume( case INST_DICT_EXISTS: { int found; - opnd = TclGetUInt4AtPtr(pc+1); + opnd = TclGetUInt4AtPtr(pc + 1); TRACE(("%u => ", opnd)); dictPtr = OBJ_AT_DEPTH(opnd); if (opnd > 1) { @@ -6803,7 +6803,7 @@ TEBCresume( JUMP_PEEPHOLE_V(found, 5, opnd+1); } case INST_DICT_GET: - opnd = TclGetUInt4AtPtr(pc+1); + opnd = TclGetUInt4AtPtr(pc + 1); TRACE(("%u => ", opnd)); dictPtr = OBJ_AT_DEPTH(opnd); if (opnd > 1) { @@ -6837,7 +6837,7 @@ TEBCresume( TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); NEXT_INST_V(5, opnd+1, 1); case INST_DICT_GET_DEF: - opnd = TclGetUInt4AtPtr(pc+1); + opnd = TclGetUInt4AtPtr(pc + 1); TRACE(("%u => ", opnd)); dictPtr = OBJ_AT_DEPTH(opnd+1); if (opnd > 1) { @@ -6868,20 +6868,20 @@ TEBCresume( case INST_DICT_SET: case INST_DICT_UNSET: case INST_DICT_INCR_IMM: - opnd = TclGetUInt4AtPtr(pc+1); - opnd2 = TclGetUInt4AtPtr(pc+5); + opnd = 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 => ", opnd, (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) { @@ -6900,18 +6900,17 @@ TEBCresume( result = Tcl_DictObjPutKeyList(interp, dictPtr, opnd, &OBJ_AT_DEPTH(opnd), 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,9 +6919,10 @@ 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, @@ -6956,7 +6956,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) { @@ -6974,18 +6974,18 @@ TEBCresume( 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) { @@ -7095,7 +7095,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) { @@ -7112,8 +7112,8 @@ TEBCresume( 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,7 +7136,7 @@ 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!"); @@ -7148,9 +7148,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; @@ -7184,11 +7184,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); + opnd = TclGetUInt4AtPtr(pc + 5); + TRACE(("%u => ", (unsigned)varIdx)); + varPtr = LOCAL(varIdx); + duiPtr = (DictUpdateInfo *)codePtr->auxDataArrayPtr[opnd].clientData; while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } @@ -7197,7 +7197,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); @@ -7244,11 +7244,11 @@ TEBCresume( NEXT_INST_F(9, 0, 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); + opnd = TclGetUInt4AtPtr(pc+5); + TRACE(("%u => ", (unsigned)varIdx)); + varPtr = LOCAL(varIdx); + duiPtr = (DictUpdateInfo *)codePtr->auxDataArrayPtr[opnd].clientData; while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } @@ -7257,7 +7257,7 @@ TEBCresume( } else { DECACHE_STACK_INFO(); dictPtr = TclPtrGetVarIdx(interp, varPtr, NULL, NULL, NULL, 0, - opnd); + varIdx); CACHE_STACK_INFO(); } if (dictPtr == NULL) { @@ -7307,7 +7307,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) { @@ -7367,11 +7367,11 @@ TEBCresume( NEXT_INST_F(1, 2, 0); 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 +7381,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) { @@ -7401,7 +7401,7 @@ TEBCresume( case INST_CLOCK_READ: { /* Read the wall clock */ Tcl_WideInt wval; Tcl_Time now; - switch (TclGetUInt1AtPtr(pc+1)) { + switch (TclGetUInt1AtPtr(pc + 1)) { case 0: /* clicks */ #ifdef TCL_WIDE_CLICKS wval = TclpGetWideClicks(); @@ -7457,11 +7457,11 @@ TEBCresume( #ifdef TCL_COMPILE_DEBUG switch (*pc) { case INST_INVOKE_STK1: - opnd = TclGetUInt1AtPtr(pc+1); + opnd = TclGetUInt1AtPtr(pc + 1); TRACE(("%u => ... after \"%.20s\": ", opnd, cmdNameBuf)); break; case INST_INVOKE_STK4: - opnd = TclGetUInt4AtPtr(pc+1); + opnd = TclGetUInt4AtPtr(pc + 1); TRACE(("%u => ... after \"%.20s\": ", opnd, cmdNameBuf)); break; case INST_EVAL_STK: @@ -7766,8 +7766,8 @@ TEBCresume( codePtr->flags |= TCL_BYTECODE_RECOMPILE; bytes = GetSrcInfoForPc(pc, codePtr, &xxx1length, NULL, NULL); - opnd = TclGetUInt4AtPtr(pc+1); - pc += (opnd-1); + opnd = TclGetUInt4AtPtr(pc + 1); + pc += (opnd - 1); assert(bytes); PUSH_OBJECT(Tcl_NewStringObj(bytes, xxx1length)); goto instEvalStk; -- cgit v0.12 From 95655e1884dc751a131dda933b5e6c57ca676d57 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 16 May 2025 11:17:51 +0000 Subject: A bit of tweaking to reduce warnings. --- generic/tclExecute.c | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index b5f3343..cc14065 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -3494,7 +3494,7 @@ TEBCresume( 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; @@ -7186,7 +7186,7 @@ TEBCresume( case INST_DICT_UPDATE_START: varIdx = TclGetUInt4AtPtr(pc + 1); opnd = TclGetUInt4AtPtr(pc + 5); - TRACE(("%u => ", (unsigned)varIdx)); + TRACE(("%u %u => ", (unsigned)varIdx, opnd)); varPtr = LOCAL(varIdx); duiPtr = (DictUpdateInfo *)codePtr->auxDataArrayPtr[opnd].clientData; while (TclIsVarLink(varPtr)) { @@ -7245,8 +7245,8 @@ TEBCresume( case INST_DICT_UPDATE_END: varIdx = TclGetUInt4AtPtr(pc + 1); - opnd = TclGetUInt4AtPtr(pc+5); - TRACE(("%u => ", (unsigned)varIdx)); + opnd = TclGetUInt4AtPtr(pc + 5); + TRACE(("%u %u => ", (unsigned)varIdx, opnd)); varPtr = LOCAL(varIdx); duiPtr = (DictUpdateInfo *)codePtr->auxDataArrayPtr[opnd].clientData; while (TclIsVarLink(varPtr)) { @@ -7716,11 +7716,13 @@ 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); +#endif Tcl_Panic("TclNRExecuteByteCode execution failure: end stack top < start stack top"); } CLANG_ASSERT(bcFramePtr); -- cgit v0.12 From ca60852f725dd32b54063569776e746702daad55 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 16 May 2025 14:18:29 +0000 Subject: Can't just blithely use unsigned; need more Tcl_Size. But that works. --- generic/tclExecute.c | 240 +++++++++++++++++++++++++-------------------------- 1 file changed, 120 insertions(+), 120 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index cc14065..7d97fb0 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -2039,8 +2039,8 @@ TEBCresume( Tcl_Obj *objPtr, *valuePtr, *value2Ptr, *part1Ptr, *part2Ptr, *tmpPtr; Tcl_Obj **objv = NULL; - Tcl_Size length, objc = 0, varIdx; - unsigned opnd; + Tcl_Size length, objc = 0, varIdx, numArgs; + unsigned tblIdx; int pcAdjustment, encIndex; Var *varPtr, *arrayPtr; #ifdef TCL_COMPILE_DEBUG @@ -2467,11 +2467,10 @@ TEBCresume( case INST_TAILCALL: { Tcl_Obj *listPtr; - - opnd = TclGetUInt1AtPtr(pc + 1); - + + numArgs = TclGetUInt1AtPtr(pc + 1); if (!(iPtr->varFramePtr->isProcCallFrame & 1)) { - TRACE(("%u => ERROR: tailcall in non-proc context\n", opnd)); + TRACE(("%u => ERROR: tailcall in non-proc context\n", (unsigned) numArgs)); Tcl_SetObjResult(interp, Tcl_NewStringObj( "tailcall can only be called from a proc or lambda", -1)); DECACHE_STACK_INFO(); @@ -2483,10 +2482,10 @@ TEBCresume( #ifdef TCL_COMPILE_DEBUG /* FIXME: What is the right thing to trace? */ { - unsigned i; + Tcl_Size i; - TRACE(("%u [", opnd)); - for (i=opnd-1 ; i>=0 ; i--) { + TRACE(("%u [", (unsigned) numArgs)); + for (i=numArgs-1 ; i>=0 ; i--) { TRACE_APPEND(("\"%.30s\"", O2S(OBJ_AT_DEPTH(i)))); if (i > 0) { TRACE_APPEND((" ")); @@ -2501,7 +2500,7 @@ TEBCresume( * stack. */ - listPtr = Tcl_NewListObj(opnd, &OBJ_AT_DEPTH(opnd-1)); + listPtr = Tcl_NewListObj(numArgs, &OBJ_AT_DEPTH(numArgs-1)); TclListObjSetElement(NULL, listPtr, 0, TclNewNamespaceObj( (Tcl_Namespace *) iPtr->varFramePtr->nsPtr)); if (iPtr->varFramePtr->tailcallPtr) { @@ -2510,7 +2509,7 @@ TEBCresume( iPtr->varFramePtr->tailcallPtr = listPtr; result = TCL_RETURN; - cleanup = opnd; + cleanup = numArgs; goto processExceptionReturn; } @@ -2564,17 +2563,17 @@ TEBCresume( 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); + numArgs = TclGetUInt4AtPtr(pc + 1); + a = tosPtr - (numArgs - 1); b = tosPtr; while (a < b) { tmpPtr = *a; @@ -2583,15 +2582,15 @@ TEBCresume( a++; b--; } - TRACE(("%u => OK\n", opnd)); + TRACE(("%u => OK\n", (unsigned)numArgs)); NEXT_INST_F(5, 0, 0); } break; 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); if (objResultPtr == NULL) { CACHE_STACK_INFO(); @@ -2600,20 +2599,20 @@ TEBCresume( } CACHE_STACK_INFO(); - TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); - NEXT_INST_V(2, opnd, 1); + TRACE_WITH_OBJ(("%u => ", (unsigned)numArgs), objResultPtr); + NEXT_INST_V(2, numArgs, 1); break; 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); + 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); break; case INST_EXPAND_START: @@ -2828,13 +2827,13 @@ TEBCresume( case INST_INVOKE_REPLACE: objc = TclGetUInt4AtPtr(pc + 1); - opnd = TclGetUInt1AtPtr(pc + 5); + numArgs = TclGetUInt1AtPtr(pc + 5); objPtr = POP_OBJECT(); objv = &OBJ_AT_DEPTH(objc-1); cleanup = objc; #ifdef TCL_COMPILE_DEBUG if (tclTraceExec >= 2) { - unsigned i; + Tcl_Size i; if (traceInstructions) { strncpy(cmdNameBuf, TclGetString(objv[0]), 20); @@ -2846,7 +2845,7 @@ TEBCresume( O2S(objPtr)); } for (i = 0; i < objc; i++) { - if (i < opnd) { + if (i < numArgs) { fprintf(stdout, "<"); TclPrintObject(stdout, objv[i], 15); fprintf(stdout, ">"); @@ -2866,14 +2865,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; } @@ -4214,7 +4213,7 @@ TEBCresume( pcAdjustment = TclGetInt1AtPtr(pc + 1); TRACE(("%d => new pc %" TCL_Z_MODIFIER "u\n", pcAdjustment, (size_t)(pc + pcAdjustment - codePtr->codeStart))); - NEXT_INST_F(opnd, 0, 0); + NEXT_INST_F(pcAdjustment, 0, 0); break; case INST_JUMP4: @@ -4289,9 +4288,9 @@ TEBCresume( * instr if lookup fails. */ - opnd = TclGetUInt4AtPtr(pc + 1); - jtPtr = (JumptableInfo *) codePtr->auxDataArrayPtr[opnd].clientData; - TRACE(("%d \"%.20s\" => ", opnd, O2S(OBJ_AT_TOS))); + tblIdx = TclGetUInt4AtPtr(pc + 1); + jtPtr = (JumptableInfo *) codePtr->auxDataArrayPtr[tblIdx].clientData; + TRACE(("%d \"%.20s\" => ", tblIdx, O2S(OBJ_AT_TOS))); hPtr = Tcl_FindHashEntry(&jtPtr->hashTable, TclGetString(OBJ_AT_TOS)); if (hPtr != NULL) { Tcl_Size jumpOffset = PTR2INT(Tcl_GetHashValue(hPtr)); @@ -4440,12 +4439,12 @@ TEBCresume( NEXT_INST_F(1, 0, 1); case INST_TCLOO_NEXT_CLASS: - opnd = TclGetUInt1AtPtr(pc + 1); + numArgs = TclGetUInt1AtPtr(pc + 1); framePtr = iPtr->varFramePtr; - valuePtr = OBJ_AT_DEPTH(opnd - 2); - objv = &OBJ_AT_DEPTH(opnd - 1); + valuePtr = OBJ_AT_DEPTH(numArgs - 2); + objv = &OBJ_AT_DEPTH(numArgs - 1); skip = 2; - TRACE(("%u => ", opnd)); + TRACE(("%u => ", (unsigned)numArgs)); if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { TRACE_APPEND(("ERROR: no TclOO call context\n")); @@ -4486,7 +4485,7 @@ TEBCresume( newDepth = i; #ifdef TCL_COMPILE_DEBUG if (tclTraceExec >= 2) { - unsigned j; + Tcl_Size j; if (traceInstructions) { strncpy(cmdNameBuf, TclGetString(objv[0]), 20); } else { @@ -4494,7 +4493,7 @@ TEBCresume( iPtr->numLevels, (pc - codePtr->codeStart)); } - for (j = 0; j < opnd; j++) { + for (j = 0; j < numArgs; j++) { TclPrintObject(stdout, objv[j], 15); fprintf(stdout, " "); } @@ -4540,11 +4539,11 @@ TEBCresume( } case INST_TCLOO_NEXT: - opnd = TclGetUInt1AtPtr(pc + 1); - objv = &OBJ_AT_DEPTH(opnd - 1); + numArgs = TclGetUInt1AtPtr(pc + 1); + objv = &OBJ_AT_DEPTH(numArgs - 1); framePtr = iPtr->varFramePtr; skip = 1; - TRACE(("%u => ", opnd)); + TRACE(("%u => ", (unsigned)numArgs)); if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) { TRACE_APPEND(("ERROR: no TclOO call context\n")); @@ -4586,7 +4585,7 @@ TEBCresume( goto gotError; #ifdef TCL_COMPILE_DEBUG } else if (tclTraceExec >= 2) { - unsigned i; + Tcl_Size i; if (traceInstructions) { strncpy(cmdNameBuf, TclGetString(objv[0]), 20); @@ -4594,7 +4593,7 @@ TEBCresume( fprintf(stdout, "%" TCL_SIZE_MODIFIER "d: (%" TCL_Z_MODIFIER "u) invoking ", iPtr->numLevels, (pc - codePtr->codeStart)); } - for (i = 0; i < opnd; i++) { + for (i = 0; i < numArgs; i++) { TclPrintObject(stdout, objv[i], 15); fprintf(stdout, " "); } @@ -4608,11 +4607,11 @@ TEBCresume( 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; + cleanup = numArgs; DECACHE_STACK_INFO(); iPtr->varFramePtr = framePtr->callerVarPtr; pc += pcAdjustment; @@ -4644,10 +4643,10 @@ TEBCresume( if (mPtr->typePtr->version < TCL_OO_METHOD_VERSION_2) { return mPtr->typePtr->callProc(mPtr->clientData, interp, - (Tcl_ObjectContext) contextPtr, opnd, objv); + (Tcl_ObjectContext) contextPtr, numArgs, objv); } return ((Tcl_MethodCallProc2 *)(void *)(mPtr->typePtr->callProc))(mPtr->clientData, interp, - (Tcl_ObjectContext) contextPtr, opnd, objv); + (Tcl_ObjectContext) contextPtr, numArgs, objv); } case INST_TCLOO_IS_OBJECT: @@ -4689,14 +4688,14 @@ TEBCresume( 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))); @@ -4851,14 +4850,14 @@ TEBCresume( * 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(("%u => ", opnd)); + TRACE(("%u => ", (unsigned)numArgs)); objResultPtr = TclLindexFlat(interp, OBJ_AT_DEPTH(numIndices), numIndices, &OBJ_AT_DEPTH(numIndices - 1)); if (!objResultPtr) { @@ -4871,16 +4870,16 @@ TEBCresume( */ TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); - NEXT_INST_V(5, opnd, -1); + 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(("%u => ", 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 @@ -5145,20 +5144,20 @@ TEBCresume( int end_indicator; int haveSecondIndex, flags; Tcl_Obj *fromIdxObj, *toIdxObj; - opnd = TclGetUInt4AtPtr(pc + 1); + numArgs = TclGetUInt4AtPtr(pc + 1); 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; + 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; + fromIdxObj = OBJ_AT_DEPTH(numArgs - 2); + toIdxObj = haveSecondIndex ? OBJ_AT_DEPTH(numArgs - 3) : NULL; if (Tcl_ListObjLength(interp, valuePtr, &length) != TCL_OK) { TRACE_ERROR(interp); goto gotError; @@ -5206,7 +5205,7 @@ TEBCresume( goto gotError; } TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); - NEXT_INST_V(6, opnd, 1); + NEXT_INST_V(6, numArgs, 1); } else { if (Tcl_ListObjReplace(interp, valuePtr, fromIdx, numToDelete, numNewElems, &OBJ_AT_DEPTH(numNewElems - 1)) != TCL_OK) { @@ -5214,7 +5213,7 @@ TEBCresume( goto gotError; } TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr))); - NEXT_INST_V(6, opnd - 1, 0); + NEXT_INST_V(6, numArgs - 1, 0); } } @@ -5576,9 +5575,9 @@ TEBCresume( NEXT_INST_F(1, 2, 1); case INST_STR_CLASS: - opnd = TclGetUInt1AtPtr(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; @@ -5587,7 +5586,7 @@ TEBCresume( end = ustring1 + slength; for (p=ustring1 ; pauxDataArrayPtr[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; @@ -6773,12 +6772,12 @@ TEBCresume( 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,19 +6799,19 @@ TEBCresume( * someone doing something else). */ - JUMP_PEEPHOLE_V(found, 5, opnd+1); + JUMP_PEEPHOLE_V(found, 5, numArgs+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))), + O2S(OBJ_AT_DEPTH(numArgs))), Tcl_GetObjResult(interp)); goto gotError; } @@ -6835,18 +6834,18 @@ TEBCresume( goto gotError; } TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_V(5, opnd+1, 1); + 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))), + O2S(OBJ_AT_DEPTH(numArgs+1))), Tcl_GetObjResult(interp)); goto gotError; } else if (dictPtr == DICT_PATH_NON_EXISTENT) { @@ -6863,19 +6862,19 @@ TEBCresume( objResultPtr = OBJ_AT_TOS; } TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_V(5, opnd+2, 1); + NEXT_INST_V(5, numArgs+2, 1); case INST_DICT_SET: case INST_DICT_UNSET: case INST_DICT_INCR_IMM: - opnd = TclGetUInt4AtPtr(pc + 1); + numArgs = TclGetUInt4AtPtr(pc + 1); varIdx = TclGetUInt4AtPtr(pc + 5); varPtr = LOCAL(varIdx); while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } - TRACE(("%u %u => ", opnd, (unsigned)varIdx)); + TRACE(("%u %u => ", (unsigned)numArgs, (unsigned)varIdx)); if (TclIsVarDirectReadable(varPtr)) { dictPtr = varPtr->value.objPtr; } else { @@ -6896,9 +6895,9 @@ 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: { int increment = TclGetInt4AtPtr(pc + 1); @@ -6924,9 +6923,9 @@ TEBCresume( 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 */ @@ -7185,10 +7184,10 @@ TEBCresume( case INST_DICT_UPDATE_START: varIdx = TclGetUInt4AtPtr(pc + 1); - opnd = TclGetUInt4AtPtr(pc + 5); - TRACE(("%u %u => ", (unsigned)varIdx, opnd)); + tblIdx = TclGetUInt4AtPtr(pc + 5); + TRACE(("%u %u => ", (unsigned)varIdx, tblIdx)); varPtr = LOCAL(varIdx); - duiPtr = (DictUpdateInfo *)codePtr->auxDataArrayPtr[opnd].clientData; + duiPtr = (DictUpdateInfo *)codePtr->auxDataArrayPtr[tblIdx].clientData; while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } @@ -7245,10 +7244,10 @@ TEBCresume( case INST_DICT_UPDATE_END: varIdx = TclGetUInt4AtPtr(pc + 1); - opnd = TclGetUInt4AtPtr(pc + 5); - TRACE(("%u %u => ", (unsigned)varIdx, opnd)); + tblIdx = TclGetUInt4AtPtr(pc + 5); + TRACE(("%u %u => ", (unsigned)varIdx, tblIdx)); varPtr = LOCAL(varIdx); - duiPtr = (DictUpdateInfo *)codePtr->auxDataArrayPtr[opnd].clientData; + duiPtr = (DictUpdateInfo *)codePtr->auxDataArrayPtr[tblIdx].clientData; while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } @@ -7457,12 +7456,12 @@ TEBCresume( #ifdef TCL_COMPILE_DEBUG switch (*pc) { 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; case INST_INVOKE_STK4: - opnd = TclGetUInt4AtPtr(pc + 1); - TRACE(("%u => ... after \"%.20s\": ", opnd, cmdNameBuf)); + numArgs = TclGetUInt4AtPtr(pc + 1); + TRACE(("%u => ... after \"%.20s\": ", (unsigned)numArgs, cmdNameBuf)); break; case INST_EVAL_STK: /* @@ -7749,6 +7748,7 @@ TEBCresume( { const char *bytes; Tcl_Size xxx1length; + unsigned offset; xxx1length = 0; @@ -7768,8 +7768,8 @@ TEBCresume( codePtr->flags |= TCL_BYTECODE_RECOMPILE; bytes = GetSrcInfoForPc(pc, codePtr, &xxx1length, NULL, NULL); - opnd = TclGetUInt4AtPtr(pc + 1); - pc += (opnd - 1); + offset = TclGetUInt4AtPtr(pc + 1); + pc += (offset - 1); assert(bytes); PUSH_OBJECT(Tcl_NewStringObj(bytes, xxx1length)); goto instEvalStk; -- cgit v0.12 From a2080b337816439027a6757c0d3e1e7a68b92842 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sun, 18 May 2025 15:53:31 +0000 Subject: Bug [3335120320]. Fix for case where extension is installed into a directory other than where Tcl is installed --- win/rules.vc | 3 ++- win/targets.vc | 1 + 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/win/rules.vc b/win/rules.vc index 414e85c..0b47765 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -24,7 +24,7 @@ _RULES_VC = 1 # For modifications that are not backward-compatible, you *must* change # the major version. RULES_VERSION_MAJOR = 1 -RULES_VERSION_MINOR = 14 +RULES_VERSION_MINOR = 15 # The PROJECT macro must be defined by parent makefile. !if "$(PROJECT)" == "" @@ -1690,6 +1690,7 @@ default-install-libraries: default-install-scripts default-install-scripts: $(OUT_DIR)\pkgIndex.tcl @echo Installing libraries to '$(SCRIPT_INSTALL_DIR)' + @if not exist "$(SCRIPT_INSTALL_DIR)" mkdir "$(SCRIPT_INSTALL_DIR)" @if exist $(LIBDIR) $(CPY) $(LIBDIR)\*.tcl "$(SCRIPT_INSTALL_DIR)" @echo Installing package index in '$(SCRIPT_INSTALL_DIR)' @$(CPY) $(OUT_DIR)\pkgIndex.tcl $(SCRIPT_INSTALL_DIR) diff --git a/win/targets.vc b/win/targets.vc index 077e8f7..08f8441 100644 --- a/win/targets.vc +++ b/win/targets.vc @@ -53,6 +53,7 @@ default-install: default-install-stubs default-install: default-install-headers default-install-headers: @echo Installing headers to '$(INCLUDE_INSTALL_DIR)' + @if not exist "$(INCLUDE_INSTALL_DIR)" $(MKDIR) "$(INCLUDE_INSTALL_DIR)" @for %f in ($(PRJ_HEADERS_PUBLIC)) do @$(COPY) %f "$(INCLUDE_INSTALL_DIR)" !endif -- cgit v0.12 From f0c7d69b86021cfddc18e0b66657f4a0e7af3807 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 18 May 2025 20:26:14 +0000 Subject: fix errors --- generic/tclExecute.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index b578b01..43e06ed 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -7112,7 +7112,7 @@ TEBCresume( } case INST_DICT_PUT: dictPtr = OBJ_AT_DEPTH(2); - TRACE(("\"%.30s\" "\"%.30s\" "\"%.30s\" => ", + TRACE(("\"%.30s\" \"%.30s\" \"%.30s\" => ", O2S(dictPtr), O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS))); allocateDict = Tcl_IsShared(dictPtr); if (allocateDict) { @@ -7134,7 +7134,7 @@ TEBCresume( } case INST_DICT_REMOVE: dictPtr = OBJ_UNDER_TOS; - TRACE(("\"%.30s\" "\"%.30s\" => ", + TRACE(("\"%.30s\" \"%.30s\" => ", O2S(dictPtr), O2S(OBJ_AT_TOS))); allocateDict = Tcl_IsShared(dictPtr); if (allocateDict) { -- cgit v0.12 From 293ec0d7c9724050d0bf7191f0587d141dbe54f7 Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 19 May 2025 07:44:59 +0000 Subject: Use the sense of space-ness from the parser, not the unicode support --- generic/tclCompCmds.c | 8 +++++++- tests/dict.test | 7 +++++++ 2 files changed, 14 insertions(+), 1 deletion(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 5253cfb..0547685 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -15,6 +15,7 @@ #include "tclInt.h" #include "tclCompile.h" +#include "tclParse.h" #include /* @@ -2078,6 +2079,10 @@ TclCompileDictLappendCmd( return TCL_OK; } +/* + * Test if the token is empty. + * We don't test if it's just comments. Fixes please, if you care. + */ static inline int IsEmptyToken( const Tcl_Token *tokenPtr) @@ -2088,7 +2093,8 @@ IsEmptyToken( end = tokenPtr[1].start + tokenPtr[1].size; for (ptr = tokenPtr[1].start; ptr < end; ptr += chLen) { chLen = TclUtfToUniChar(ptr, &ucs4); - if (!Tcl_UniCharIsSpace(ucs4)) { + // Can't use Tcl_UniCharIsSpace; see test dict-22.24 + if (ucs4 < 0 || ucs4 > 255 || tclCharTypeTable[ucs4] != TYPE_SPACE) { return 0; } } diff --git a/tests/dict.test b/tests/dict.test index a620b23..834df58 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -1667,6 +1667,13 @@ 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} proc linenumber {} { dict get [info frame -1] line -- cgit v0.12 From 912328358c508e1474baa93e44f4bbe7c95be5f2 Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 19 May 2025 09:04:41 +0000 Subject: Don't generate the next clause of [for] if it's known to be empty --- generic/tclCompCmds.c | 20 ++++++++++++-------- 1 file changed, 12 insertions(+), 8 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 0547685..ab54e53 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -2638,7 +2638,7 @@ TclCompileForCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *startTokenPtr, *testTokenPtr, *nextTokenPtr, *bodyTokenPtr; - Tcl_ExceptionRange bodyRange, nextRange; + Tcl_ExceptionRange bodyRange, nextRange = -1; Tcl_BytecodeLabel evalBody, testCondition; if (parsePtr->numWords != 5) { @@ -2707,13 +2707,15 @@ TclCompileForCmd( * TCL_CONTINUE but rather just TCL_BREAK. */ - nextRange = MAKE_LOOP_RANGE(); - envPtr->exceptAuxArrayPtr[nextRange].supportsContinue = 0; CONTINUE_TARGET( bodyRange); - CATCH_RANGE(nextRange) { - BODY( nextTokenPtr, 3); + if (!IsEmptyToken(nextTokenPtr)) { + nextRange = MAKE_LOOP_RANGE(); + envPtr->exceptAuxArrayPtr[nextRange].supportsContinue = 0; + CATCH_RANGE(nextRange) { + BODY( nextTokenPtr, 3); + } + OP( POP); } - OP( POP); /* * Compile the test expression then emit the conditional jump that @@ -2730,9 +2732,11 @@ TclCompileForCmd( */ BREAK_TARGET( bodyRange); - BREAK_TARGET( nextRange); FINALIZE_LOOP(bodyRange); - FINALIZE_LOOP(nextRange); + if (nextRange != -1) { + BREAK_TARGET( nextRange); + FINALIZE_LOOP(nextRange); + } /* * The for command's result is an empty string. -- cgit v0.12 From bbb91873becae4ad7dc5e71a9e2e5bb81ea2d461 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 19 May 2025 10:27:26 +0000 Subject: Update version in .project file --- .project | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.project b/.project index f274ff9..8a6f036 100644 --- a/.project +++ b/.project @@ -1,6 +1,6 @@ - tcl9 + tcl9.0 -- cgit v0.12 From 7a2984163723c3d9a4eb8b60fc8447c565c2edf0 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Mon, 19 May 2025 11:52:10 +0000 Subject: Some small clarification to abstract list method docs --- doc/ObjectType.3 | 21 ++++++++++++++++----- 1 file changed, 16 insertions(+), 5 deletions(-) diff --git a/doc/ObjectType.3 b/doc/ObjectType.3 index 688a04a..1bcf503 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,13 @@ 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. Further, 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. + .SS "THE LENGTHPROC FIELD" .PP The \fBLengthProc\fR function correlates with the \fBTcl_ListObjLength\fR @@ -378,8 +386,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 +415,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, -- cgit v0.12 From 673fb318a927a191823b49969238a50358a41ea4 Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 19 May 2025 11:58:18 +0000 Subject: Promote IsEmptyToken to TclIsEmptyToken, and use in other relevant places --- generic/tclCompCmds.c | 31 +++---------------------------- generic/tclCompCmdsGR.c | 18 ++++++++---------- generic/tclCompCmdsSZ.c | 8 +++++--- generic/tclCompile.c | 38 ++++++++++++++++++++++++++++++++++++++ generic/tclCompile.h | 1 + 5 files changed, 55 insertions(+), 41 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index ab54e53..22e1f3d 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -15,7 +15,6 @@ #include "tclInt.h" #include "tclCompile.h" -#include "tclParse.h" #include /* @@ -2079,28 +2078,6 @@ TclCompileDictLappendCmd( return TCL_OK; } -/* - * Test if the token is empty. - * We don't test if it's just comments. Fixes please, if you care. - */ -static inline int -IsEmptyToken( - 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 (ucs4 < 0 || ucs4 > 255 || tclCharTypeTable[ucs4] != TYPE_SPACE) { - return 0; - } - } - return 1; -} - /* Compile [dict with]. Delegates code issuing to IssueDictWithEmpty() and * IssueDictWithBodied(). */ int @@ -2143,11 +2120,9 @@ TclCompileDictWithCmd( * Test if the last word is an empty script; if so, we can compile it in * all cases, but if it is non-empty we need local variable table entries * to hold the temporary variables (used to keep stack usage simple). - * - * We don't test if it's just comments. Fixes please, if you care. */ - if (!IsEmptyToken(tokenPtr)) { + if (!TclIsEmptyToken(tokenPtr)) { if (!EnvHasLVT(envPtr)) { return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr); @@ -2673,7 +2648,7 @@ TclCompileForCmd( * Inline compile the initial command. */ - BODY(startTokenPtr, 1); + BODY( startTokenPtr, 1); OP( POP); /* @@ -2708,7 +2683,7 @@ TclCompileForCmd( */ CONTINUE_TARGET( bodyRange); - if (!IsEmptyToken(nextTokenPtr)) { + if (!TclIsEmptyToken(nextTokenPtr)) { nextRange = MAKE_LOOP_RANGE(); envPtr->exceptAuxArrayPtr[nextRange].supportsContinue = 0; CATCH_RANGE(nextRange) { diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 7f1e917..c8d29a8 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -280,14 +280,12 @@ TclCompileIfCmd( code = TCL_ERROR; goto done; } - if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - if (IS_TOKEN_LITERALLY(tokenPtr, "then")) { - 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; } } @@ -296,7 +294,7 @@ TclCompileIfCmd( */ if (compileScripts) { - BODY(tokenPtr, wordIdx); + BODY( tokenPtr, wordIdx); } if (realCond) { @@ -363,7 +361,7 @@ TclCompileIfCmd( * Compile the else command body. */ - BODY(tokenPtr, wordIdx); + BODY( tokenPtr, wordIdx); } /* diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 6d14873..02fcc4d 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -2988,7 +2988,7 @@ TclCompileTryCmd( goto failedToCompile; } // Special case: empty finally clause - if (finallyToken[1].size == 0) { + if (TclIsEmptyToken(finallyToken)) { finallyToken = NULL; } } else { @@ -3198,7 +3198,7 @@ IssueTryClausesInstructions( } } - if (handlers[i].tokenPtr[1].size == 0) { + if (TclIsEmptyToken(handlers[i].tokenPtr)) { // Empty handler body; can't generate non-trivial result tuple PUSH( ""); FWDJUMP( JUMP, noError[i]); @@ -3394,7 +3394,7 @@ IssueTryTraplessClausesInstructions( } } - if (handlers[i].tokenPtr[1].size == 0) { + if (TclIsEmptyToken(handlers[i].tokenPtr)) { // Empty handler body; can't generate non-trivial result tuple PUSH( ""); FWDJUMP( JUMP, noError[i]); @@ -3642,6 +3642,7 @@ IssueTryClausesFinallyInstructions( OP4( BEGIN_CATCH, range); FWDLABEL( bodyStart); } + // TODO: Simplify based on TclIsEmptyToken(handlers[i].tokenPtr) BODY( handlers[i].tokenPtr, 5 + i*4); ExceptionRangeEnds(envPtr, range); PUSH( "0"); @@ -3927,6 +3928,7 @@ IssueTryTraplessClausesFinallyInstructions( 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); diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 863aa65..b5aaed6 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -15,6 +15,7 @@ #include "tclInt.h" #define ALLOW_DEPRECATED_OPCODES #include "tclCompile.h" +#include "tclParse.h" #include /* @@ -4746,6 +4747,43 @@ 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 (ucs4 < 0 || ucs4 > 255 || tclCharTypeTable[ucs4] != TYPE_SPACE) { + return 0; + } + } + return 1; +} + #ifdef TCL_COMPILE_STATS /* *---------------------------------------------------------------------- diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 4158336..ee914bb 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -1313,6 +1313,7 @@ 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, -- cgit v0.12 From 16999286b60983f577bcc25d5a300bc6bbdbdfe6 Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 19 May 2025 12:01:16 +0000 Subject: Disable deprecation notices with MSVC; they can get them if they turn on support for C23 --- generic/tclCompile.h | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclCompile.h b/generic/tclCompile.h index ee914bb..1c184d3 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -603,11 +603,11 @@ typedef struct ByteCode { #elif defined(ALLOW_DEPRECATED_OPCODES) #define DEPRECATED_OPCODE(name) \ name -#elif (defined(__STDC_VERSION__) && __STDC_VERSION__ >= 202311L) \ - || (defined(_MSC_VER) && (_MSC_VER >= 1900)) +#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 -- cgit v0.12 From 8195694d547fd42c504dcf0405f0360b74a9e463 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 20 May 2025 07:55:29 +0000 Subject: A few more corrections to Tcl_BounceRefCount usage; definitely no leaks in test suite --- generic/tclCompCmds.c | 1 - generic/tclCompCmdsGR.c | 10 +++------- generic/tclCompile.c | 1 + generic/tclExecute.c | 20 +++++--------------- 4 files changed, 9 insertions(+), 23 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 22e1f3d..6189eb7 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -1450,7 +1450,6 @@ TclCompileDictCreateCmd( keyToken = TokenAfter(valueToken); Tcl_DictObjPut(NULL, dictObj, keyObj, valueObj); Tcl_BounceRefCount(keyObj); - Tcl_BounceRefCount(valueObj); } /* diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index c8d29a8..f8390cf 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -2106,7 +2106,7 @@ TclCompileRegsubCmd( goto done; } tokenPtr = TokenAfter(tokenPtr); - Tcl_DecrRefCount(patternObj); + Tcl_BounceRefCount(patternObj); TclNewObj(patternObj); if (!TclWordKnownAtCompileTime(tokenPtr, patternObj)) { goto done; @@ -2186,12 +2186,8 @@ TclCompileRegsubCmd( done: Tcl_DStringFree(&pattern); - if (patternObj) { - Tcl_DecrRefCount(patternObj); - } - if (replacementObj) { - Tcl_BounceRefCount(replacementObj); - } + Tcl_BounceRefCount(patternObj); + Tcl_BounceRefCount(replacementObj); return result; } diff --git a/generic/tclCompile.c b/generic/tclCompile.c index b5aaed6..4ef637c 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1998,6 +1998,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. * *---------------------------------------------------------------------- */ diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 43e06ed..d179129 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -7119,9 +7119,7 @@ TEBCresume( dictPtr = Tcl_DuplicateObj(dictPtr); } if (Tcl_DictObjPut(interp, dictPtr, OBJ_UNDER_TOS, OBJ_AT_TOS) != TCL_OK) { - if (allocateDict) { - Tcl_BounceRefCount(dictPtr); - } + Tcl_BounceRefCount(dictPtr); TRACE_ERROR(interp); goto gotError; } @@ -7141,9 +7139,7 @@ TEBCresume( dictPtr = Tcl_DuplicateObj(dictPtr); } if (Tcl_DictObjRemove(interp, dictPtr, OBJ_AT_TOS) != TCL_OK) { - if (allocateDict) { - Tcl_BounceRefCount(dictPtr); - } + Tcl_BounceRefCount(dictPtr); TRACE_ERROR(interp); goto gotError; } @@ -7352,9 +7348,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; } @@ -7401,9 +7395,7 @@ TEBCresume( if (Tcl_ListObjAppendElement(interp, valuePtr, OBJ_AT_TOS) != TCL_OK) { TclDecrRefCount(valuePtr); - if (allocateDict) { - TclDecrRefCount(dictPtr); - } + Tcl_BounceRefCount(dictPtr); TRACE_ERROR(interp); goto gotError; } @@ -7411,9 +7403,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; } -- cgit v0.12 From d64b72d8fd9f3adbbe1aa7bf621d7cf17fc69591 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 20 May 2025 08:41:34 +0000 Subject: fix (rare) merge error --- generic/tclExecute.c | 1 - 1 file changed, 1 deletion(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 24e092d..0da4478 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -4734,7 +4734,6 @@ TEBCresume( #ifdef TCL_COMPILE_DEBUG if (tclTraceExec >= TCL_TRACE_BYTECODE_EXEC_COMMANDS) { Tcl_Size j; - Tcl_Size j; if (traceInstructions) { strncpy(cmdNameBuf, TclGetString(objv[0]), 20); } else { -- cgit v0.12 From 261e788b4b30a552d9623a1dc68502e64af2cf51 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Wed, 21 May 2025 00:53:05 +0000 Subject: Update docs --- doc/encoding.n | 8 ++++++++ doc/exec.n | 6 ++++++ 2 files changed, 14 insertions(+) diff --git a/doc/encoding.n b/doc/encoding.n index 43da934..7789778 100644 --- a/doc/encoding.n +++ b/doc/encoding.n @@ -104,6 +104,14 @@ Returns a list of the names of encoding profiles. See \fBPROFILES\fR below. Set the system encoding to \fIencoding\fR. If \fIencoding\fR is omitted then the command returns the current system encoding. The system encoding is used whenever Tcl passes strings to system calls. +.TP +\fBencoding user\fR +.VS TIP716 +Returns the name of encoding as per the user's preferences. On Windows +systems, this is based on the user's code page settings in the registry. +On other platforms, the returned value is the same as returned by +\fBencoding system\fR. +.VE TIP716 .\" Do not put .VS on whole section as that messes up the bullet list alignment .SH PROFILES .PP diff --git a/doc/exec.n b/doc/exec.n index 4992922..d36c5ab 100644 --- a/doc/exec.n +++ b/doc/exec.n @@ -33,6 +33,12 @@ of the pipeline specification. The following switches are currently supported: .\" OPTION: -ignorestderr .TP 13 +\fB\-encoding \fIencodingName\fR +. +Specifies the name of the encoding to use to decode the output of the first +subprocess. Defaults to that returned by the \fBencoding system\fR command. +.\" OPTION: -ignorestderr +.TP 13 \fB\-ignorestderr\fR . Stops the \fBexec\fR command from treating the output of messages to the -- cgit v0.12 From c1ee663c102ef4ff430205e2069826e5c8e9d41e Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 21 May 2025 08:03:20 +0000 Subject: Add back missing file. I don't know why it keeps getting nuked... --- win/tcltest.rc | 75 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 75 insertions(+) create mode 100644 win/tcltest.rc diff --git a/win/tcltest.rc b/win/tcltest.rc new file mode 100644 index 0000000..ea55a62 --- /dev/null +++ b/win/tcltest.rc @@ -0,0 +1,75 @@ +// +// Version Resource Script +// + +#include +#include + +// +// build-up the name suffix that defines the type of build this is. +// +#if STATIC_BUILD +#define SUFFIX_STATIC "s" +#else +#define SUFFIX_STATIC "" +#endif + +#if DEBUG && !UNCHECKED +#define SUFFIX_DEBUG "g" +#else +#define SUFFIX_DEBUG "" +#endif + +#define SUFFIX SUFFIX_STATIC SUFFIX_DEBUG + + +LANGUAGE 0x9, 0x1 /* LANG_ENGLISH, SUBLANG_DEFAULT */ + +VS_VERSION_INFO VERSIONINFO + FILEVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL + PRODUCTVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL + FILEFLAGSMASK 0x3fL +#ifdef DEBUG + FILEFLAGS VS_FF_DEBUG +#else + FILEFLAGS 0x0L +#endif + FILEOS VOS__WINDOWS32 + FILETYPE VFT_APP + FILESUBTYPE 0x0L +BEGIN + BLOCK "StringFileInfo" + BEGIN + BLOCK "040904b0" + BEGIN + VALUE "FileDescription", "Tcltest Application\0" + VALUE "OriginalFilename", "tcltest" STRINGIFY(TCL_MAJOR_VERSION) STRINGIFY(TCL_MINOR_VERSION) SUFFIX ".exe\0" + VALUE "FileVersion", TCL_PATCH_LEVEL + VALUE "LegalCopyright", "Copyright \251 1987-2022 Regents of the University of California and other parties\0" + VALUE "ProductName", "Tcl " TCL_VERSION " for Windows\0" + VALUE "ProductVersion", TCL_PATCH_LEVEL + END + END + BLOCK "VarFileInfo" + BEGIN + VALUE "Translation", 0x409, 1200 + END +END + +// +// Icon +// + +tclsh ICON DISCARDABLE "tclsh.ico" + +// +// This is needed for Windows 8.1 onwards. +// + +#ifndef RT_MANIFEST +#define RT_MANIFEST 24 +#endif +#ifndef CREATEPROCESS_MANIFEST_RESOURCE_ID +#define CREATEPROCESS_MANIFEST_RESOURCE_ID 1 +#endif +CREATEPROCESS_MANIFEST_RESOURCE_ID RT_MANIFEST "tclsh.exe.manifest" -- cgit v0.12 From 71edf928c831a9cfa918da22ce316defb50858bf Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 21 May 2025 10:52:30 +0000 Subject: Use the right internal macro --- generic/tclCompile.c | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 4ef637c..bdc6298 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -15,7 +15,6 @@ #include "tclInt.h" #define ALLOW_DEPRECATED_OPCODES #include "tclCompile.h" -#include "tclParse.h" #include /* @@ -4778,7 +4777,7 @@ TclIsEmptyToken( for (ptr = tokenPtr[1].start; ptr < end; ptr += chLen) { chLen = TclUtfToUniChar(ptr, &ucs4); // Can't use Tcl_UniCharIsSpace; see test dict-22.24 - if (ucs4 < 0 || ucs4 > 255 || tclCharTypeTable[ucs4] != TYPE_SPACE) { + if (!TclIsSpaceProcM((unsigned) ucs4)) { return 0; } } -- cgit v0.12 From 70debab1cec7af3fb066d649a8e98a42c3e51b2c Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Thu, 22 May 2025 03:19:42 +0000 Subject: Implement expr in/ni for repeated and reversed list types --- generic/tclListTypes.c | 159 ++++++++++++++++++++++++++++++++++++++++++++++--- tests/listTypes.test | 23 +++++++ 2 files changed, 173 insertions(+), 9 deletions(-) diff --git a/generic/tclListTypes.c b/generic/tclListTypes.c index 5c71d35..099d6ff 100644 --- a/generic/tclListTypes.c +++ b/generic/tclListTypes.c @@ -23,7 +23,30 @@ #define LRANGE_LENGTH_THRESHOLD 100 /* - * TclObjArray stores a reference counted Tcl_Obj array. + * Returns index of first matching entry in an array of Tcl_Obj, + * TCL_INDEX_NONE if not found. + */ +static Tcl_Size +TclFindInArrayOfObjs(Tcl_Size haySize, Tcl_Obj * const hayElems[], Tcl_Obj *needlePtr) +{ + const char *needle; + Tcl_Size needleLen; + needle = TclGetStringFromObj(needlePtr, &needleLen); + for (int i = 0; i < haySize; i++) { + const char *hayElem; + Tcl_Size hayElemLen; + 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, less functional version of Tcl lists. */ typedef struct TclObjArray { Tcl_Size refCount; /* Reference count */ @@ -90,6 +113,13 @@ TclObjArrayElems(TclObjArray *arrayPtr, Tcl_Obj ***objPtrPtr) 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 TclFindInArrayOfObjs(arrayPtr->nelems, arrayPtr->elemPtrs, needlePtr); +} + /* 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) @@ -108,6 +138,88 @@ TclNormalizeRangeLimits(Tcl_Size *startPtr, Tcl_Size *endPtr, Tcl_Size len) } /* + * 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); + } + + int status; + Tcl_Size haySize; + + status = TclListObjLength(interp, hayPtr, &haySize); + if (status != TCL_OK) { + return status; + } + + if (haySize == 0) { + *foundPtr = 0; + return TCL_OK; + } + + const char *needle; + Tcl_Size needleLen; + 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 = + TclFindInArrayOfObjs(haySize, hayElems, needlePtr) == TCL_INDEX_NONE + ? 0 + : 1; + return TCL_OK; + } + + /* Abstract list */ + for (int i = 0; i < haySize; i++) { + Tcl_Obj *hayElemObj; + const char *hayElem; + Tcl_Size hayElemLen; + if (indexProc(interp, hayPtr, i, &hayElemObj) != TCL_OK) { + return TCL_ERROR; + } + assert(hayElemObj != NULL); // Should never be NULL for i < haySize + hayElem = TclGetStringFromObj(hayElemObj, &hayElemLen); + if (needleLen == hayElemLen && + memcmp(needle, hayElem, needleLen) == 0) { + *foundPtr = 1; + return TCL_OK; + } + } + *foundPtr = 0; + return TCL_OK; +} + +/* *------------------------------------------------------------------------ * * TclAbstractListUpdateString -- @@ -218,9 +330,10 @@ static void TclAbstractListUpdateString (Tcl_Obj *objPtr) static void LreverseFreeIntrep(Tcl_Obj *objPtr); static void LreverseDupIntrep(Tcl_Obj *srcObj, Tcl_Obj *dupObj); -static Tcl_ObjTypeLengthProc LreverseTypeLength; -static Tcl_ObjTypeIndexProc LreverseTypeIndex; -static Tcl_ObjTypeReverseProc LreverseTypeReverse; +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. @@ -242,7 +355,7 @@ static const Tcl_ObjType lreverseType = { NULL, /* getElementsProc */ NULL, /* setElementProc - FUTURES */ NULL, /* replaceProc - FUTURES */ - NULL) /* inOperProc - FUTURES */ + LreverseTypeInOper) /* inOperProc */ }; void @@ -297,6 +410,19 @@ LreverseTypeReverse(Tcl_Interp *interp, return TCL_OK; } +/* Implementation of Tcl_ObjType.inOperProc for lreverseType */ +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); +} + + /* *------------------------------------------------------------------------ * @@ -402,8 +528,9 @@ Tcl_ListObjReverse( static void LrepeatFreeIntrep(Tcl_Obj *objPtr); static void LrepeatDupIntrep(Tcl_Obj *srcObj, Tcl_Obj *dupObj); -static Tcl_ObjTypeLengthProc LrepeatTypeLength; -static Tcl_ObjTypeIndexProc LrepeatTypeIndex; +static Tcl_ObjTypeLengthProc LrepeatTypeLength; +static Tcl_ObjTypeIndexProc LrepeatTypeIndex; +static Tcl_ObjTypeInOperatorProc LrepeatTypeInOper; /* * IMPORTANT - current implementation is read-only. That is, the @@ -424,7 +551,7 @@ static const Tcl_ObjType lrepeatType = { NULL, /* getElementsProc */ NULL, /* Must be NULL - see above comment */ NULL, /* Must be NULL - see above comment */ - NULL) /* inOperProc - FUTURES */ + LrepeatTypeInOper) /* inOperProc */ }; void @@ -472,6 +599,20 @@ LrepeatTypeIndex( return TCL_OK; } +/* Implementation of Tcl_ObjType.inOperProc for lrepeatType */ +int +LrepeatTypeInOper( + Tcl_Interp *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; +} + /* *------------------------------------------------------------------------ * @@ -617,7 +758,7 @@ static const Tcl_ObjType lrangeType = { NULL, /* getElementsProc */ NULL, /* setElementProc, see above comment */ NULL, /* replaceProc, see above comment */ - NULL) /* inOperProc - FUTURES */ + NULL) /* inOperProc */ }; static inline int diff --git a/tests/listTypes.test b/tests/listTypes.test index 8722053..a70cc3f 100644 --- a/tests/listTypes.test +++ b/tests/listTypes.test @@ -906,6 +906,29 @@ namespace eval listtype { } ################################################################ + # 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 # -- cgit v0.12 From cb54d306f90f8f832b2fa6f5adc64285f0de1fe2 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 22 May 2025 08:11:34 +0000 Subject: MSVC doesn't like #ifdef in arguments to a macro --- generic/tclExecute.c | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 0da4478..7a30c36 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -4424,31 +4424,30 @@ TEBCresume( 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); + 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[( -#ifndef REMOVE_DEPRECATED_OPCODES - *pc==INST_JUMP_FALSE1 || -#endif - *pc==INST_JUMP_FALSE) ? 0 : 1])); /* TODO - check claim that taking address of b harms performance */ /* TODO - consider optimization search for constants */ @@ -7028,7 +7027,7 @@ TEBCresume( value2Ptr = OBJ_AT_TOS; valuePtr = OBJ_UNDER_TOS; TRACE(("\"%.20s\" \"%.20s\" %u => ", - O2S(valuePtr), O2S(value2Ptr), cmpLen)); + O2S(valuePtr), O2S(value2Ptr), (unsigned) cmpLen)); if (TclListObjGetElements(interp, valuePtr, &aObjc, &aObjv) != TCL_OK) { TRACE_ERROR(interp); goto gotError; -- cgit v0.12 From aef01f53945ad861aaa46fa9c7f10de49ee6fa5e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 22 May 2025 09:25:06 +0000 Subject: Minor optimization: Make sure that TclIsSpaceProcM() doesn't call TclIsSpaceProc() for 'negative' byte values --- generic/tclInt.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 98cab9b..75608ae 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3705,7 +3705,7 @@ MODULE_SCOPE void TclZipfsFinalize(void); MODULE_SCOPE int TclIsSpaceProc(int byte); #define TclIsSpaceProcM(byte) \ - (((byte) > 0x20) ? 0 : TclIsSpaceProc(byte)) + (((unsigned)(byte) > 0x20) ? 0 : TclIsSpaceProc(byte)) /* *---------------------------------------------------------------- -- cgit v0.12 From 71b8db3a9abad27a6663c5dfea9b90f101bb61e2 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 22 May 2025 09:39:11 +0000 Subject: Improvements to TRACE macros and reduce warnings (on some platforms/configs) --- generic/tclExecute.c | 349 ++++++++++++++++++++++++++------------------------- 1 file changed, 177 insertions(+), 172 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 7a30c36..d09a56e 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -425,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 @@ -434,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); \ @@ -463,12 +468,18 @@ VarHashFindVar( } # define O2S(objPtr) \ (objPtr ? TclGetString(objPtr) : "") +# 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) +# define TRACE_APPEND_OBJ(objPtr) +# define TRACE_APPEND_NUM_OBJ(objPtr) #endif /* TCL_COMPILE_DEBUG */ #ifndef REMOVE_DEPRECATED_OPCODES @@ -1914,7 +1925,7 @@ ArgumentBCEnter( if (GetSrcInfoForPc(pc, codePtr, NULL, NULL, &cmd)) { TclArgumentBCEnter(interp, objv, objc, codePtr, &tdPtr->cmdFrame, cmd, - pc - codePtr->codeStart); + PC_REL); } } @@ -2126,7 +2137,7 @@ TEBCresume( #ifdef TCL_COMPILE_DEBUG 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 @@ -2185,7 +2196,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)); /* @@ -2330,7 +2341,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); } @@ -2450,9 +2461,8 @@ TEBCresume( 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); } @@ -2493,9 +2503,8 @@ TEBCresume( TRACE(("[%.30s] => YIELD...\n", O2S(valuePtr))); } 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); } @@ -2569,7 +2578,7 @@ TEBCresume( TRACE_APPEND((" ")); } } - TRACE_APPEND(("] => RETURN...")); + TRACE_APPEND(("] => RETURN...\n")); } #endif @@ -2737,7 +2746,7 @@ 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)); + TRACE(("=> mark depth as %" SIZEd "\n", CURR_DEPTH)); NEXT_INST_F0(1, 0); break; @@ -2755,7 +2764,7 @@ 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: { @@ -2894,10 +2903,10 @@ TEBCresume( 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)); + fprintf(stdout, "%" SIZEd ": (%" SIZEd ") invoking ", + iPtr->numLevels, PC_REL); } for (i = 0; i < objc; i++) { TclPrintObject(stdout, objv[i], 15); @@ -2945,12 +2954,11 @@ TEBCresume( 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)); } for (i = 0; i < objc; i++) { if (i < numArgs) { @@ -3019,7 +3027,7 @@ TEBCresume( */ objResultPtr = varPtr->value.objPtr; - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + TRACE_APPEND_OBJ(objResultPtr); NEXT_INST_F(2, 0, 1); } pcAdjustment = 2; @@ -3043,7 +3051,7 @@ TEBCresume( */ objResultPtr = varPtr->value.objPtr; - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + TRACE_APPEND_OBJ(objResultPtr); NEXT_INST_F(5, 0, 1); } pcAdjustment = 5; @@ -3080,7 +3088,7 @@ TEBCresume( */ objResultPtr = varPtr->value.objPtr; - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + TRACE_APPEND_OBJ(objResultPtr); NEXT_INST_F(pcAdjustment, 1, 1); } } @@ -3126,7 +3134,7 @@ TEBCresume( */ objResultPtr = varPtr->value.objPtr; - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + TRACE_APPEND_OBJ(objResultPtr); NEXT_INST_V(1, cleanup, 1); } pcAdjustment = 1; @@ -3146,7 +3154,7 @@ TEBCresume( TRACE_ERROR(interp); goto gotError; } - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + TRACE_APPEND_OBJ(objResultPtr); NEXT_INST_V(pcAdjustment, cleanup, 1); /* @@ -3246,7 +3254,7 @@ TEBCresume( NEXT_INST_F0(pcAdjustment + 1, 0); } #else - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + TRACE_APPEND_OBJ(objResultPtr); #endif Tcl_IncrRefCount(objResultPtr); NEXT_INST_F0(pcAdjustment, 0); @@ -3424,7 +3432,7 @@ TEBCresume( 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: @@ -3521,7 +3529,7 @@ TEBCresume( TRACE_ERROR(interp); goto gotError; } - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + TRACE_APPEND_OBJ(objResultPtr); NEXT_INST_V(pcAdjustment, cleanup, 1); lappendList: @@ -3595,7 +3603,7 @@ TEBCresume( if (!objResultPtr) { goto errorInLappendListPtr; } - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + TRACE_APPEND_OBJ(objResultPtr); NEXT_INST_V(pcAdjustment, cleanup, 1); errorInLappendListPtr: TRACE_ERROR(interp); @@ -3866,7 +3874,7 @@ 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); @@ -4137,7 +4145,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)) { @@ -4215,7 +4223,7 @@ 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: @@ -4403,15 +4411,15 @@ TEBCresume( case INST_JUMP1: DEPRECATED_OPCODE_MARK(INST_JUMP1); pcAdjustment = TclGetInt1AtPtr(pc + 1); - TRACE(("%d => new pc %" TCL_Z_MODIFIER "u\n", pcAdjustment, - (size_t)(pc + pcAdjustment - codePtr->codeStart))); + 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 %" TCL_Z_MODIFIER "u\n", pcAdjustment, - (pc + pcAdjustment - codePtr->codeStart))); + TRACE(("%d => new pc %" SIZEd "\n", pcAdjustment, + PC_REL + pcAdjustment)); NEXT_INST_F0(pcAdjustment, 0); { @@ -4462,9 +4470,9 @@ TEBCresume( #ifndef REMOVE_DEPRECATED_OPCODES || (*pc == INST_JUMP_TRUE1) #endif - ) { - TRACE_APPEND(("%.20s true, new pc %" TCL_T_MODIFIER "u\n", O2S(valuePtr), - (pc + jmpOffset[1] - codePtr->codeStart))); + ) { + TRACE_APPEND(("%.20s true, new pc %" SIZEd "\n", O2S(valuePtr), + PC_REL + jmpOffset[1])); } else { TRACE_APPEND(("%.20s true\n", O2S(valuePtr))); } @@ -4476,8 +4484,8 @@ TEBCresume( ) { TRACE_APPEND(("%.20s false\n", O2S(valuePtr))); } else { - TRACE_APPEND(("%.20s false, new pc %" TCL_T_MODIFIER "u\n", O2S(valuePtr), - (pc + jmpOffset[0] - codePtr->codeStart))); + TRACE_APPEND(("%.20s false, new pc %" SIZEd "\n", O2S(valuePtr), + PC_REL + jmpOffset[0])); } } #endif @@ -4501,8 +4509,8 @@ TEBCresume( if (hPtr != NULL) { Tcl_Size jumpOffset = PTR2INT(Tcl_GetHashValue(hPtr)); - TRACE_APPEND(("found in table, new pc %" TCL_Z_MODIFIER "u\n", - (pc - codePtr->codeStart + jumpOffset))); + TRACE_APPEND(("found in table, new pc %" SIZEu "\n", + PC_REL + jumpOffset)); NEXT_INST_F0(jumpOffset, 1); } else { TRACE_APPEND(("not found in table\n")); @@ -4530,8 +4538,8 @@ TEBCresume( if (hPtr != NULL) { Tcl_Size jumpOffset = PTR2INT(Tcl_GetHashValue(hPtr)); - TRACE_APPEND(("found in table, new pc %" TCL_Z_MODIFIER "u\n", - (pc - codePtr->codeStart + jumpOffset))); + TRACE_APPEND(("found in table, new pc %" SIZEu "\n", + PC_REL + jumpOffset)); NEXT_INST_F0(jumpOffset, 1); } else { jumpTableNumFallthrough: @@ -4596,7 +4604,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); } { @@ -4636,7 +4644,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); } @@ -4736,9 +4744,8 @@ TEBCresume( if (traceInstructions) { strncpy(cmdNameBuf, TclGetString(objv[0]), 20); } else { - fprintf(stdout, "%" TCL_SIZE_MODIFIER "d: (%" TCL_T_MODIFIER "d) invoking ", - iPtr->numLevels, - (pc - codePtr->codeStart)); + fprintf(stdout, "%" SIZEd ": (%" SIZEd ") invoking ", + iPtr->numLevels, PC_REL); } for (j = 0; j < numArgs; j++) { TclPrintObject(stdout, objv[j], 15); @@ -4848,8 +4855,8 @@ TEBCresume( 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)); + fprintf(stdout, "%" SIZEd ": (%" SIZEu ") invoking ", + iPtr->numLevels, PC_REL); } for (i = 0; i < numArgs; i++) { TclPrintObject(stdout, objv[i], 15); @@ -4963,7 +4970,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 */ @@ -5039,7 +5046,7 @@ 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 @@ -5101,7 +5108,7 @@ 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 */ @@ -5128,7 +5135,7 @@ TEBCresume( * Set result. */ - TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); + TRACE_APPEND_OBJ(objResultPtr); NEXT_INST_V(5, numArgs, -1); case INST_LSET_FLAT: @@ -5173,7 +5180,7 @@ TEBCresume( * Set result. */ CACHE_STACK_INFO(); - TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); + TRACE_APPEND_OBJ(objResultPtr); NEXT_INST_V(5, numIndices + 1, -1); case INST_LSET_LIST: /* 'lset' with 4 args */ @@ -5210,7 +5217,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 @@ -5261,7 +5268,7 @@ TEBCresume( if (toIdxEnc == -1) { emptyList: TclNewObj(objResultPtr); - TRACE_APPEND(("\"%.30s\"", O2S(objResultPtr))); + TRACE_APPEND_OBJ(objResultPtr); NEXT_INST_F(9, 1, 1); } toIdx = TclIndexDecode(toIdxEnc, objc - 1); @@ -5298,7 +5305,7 @@ TEBCresume( } CACHE_STACK_INFO(); - TRACE_APPEND(("\"%.30s\"", O2S(objResultPtr))); + TRACE_APPEND_OBJ(objResultPtr); NEXT_INST_F(9, 1, 1); case INST_LIST_IN: @@ -5386,14 +5393,14 @@ 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){ TRACE_ERROR(interp); goto gotError; } - TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr))); + TRACE_APPEND_OBJ(valuePtr); NEXT_INST_F0(1, 1); } @@ -5462,7 +5469,7 @@ TEBCresume( Tcl_DecrRefCount(objResultPtr); goto gotError; } - TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); + TRACE_APPEND_OBJ(objResultPtr); NEXT_INST_V(6, numArgs, 1); } else { if (Tcl_ListObjReplace(interp, valuePtr, fromIdx, numToDelete, @@ -5470,7 +5477,7 @@ TEBCresume( TRACE_ERROR(interp); goto gotError; } - TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr))); + TRACE_APPEND_OBJ(valuePtr); NEXT_INST_V(6, numArgs - 1, 0); } } @@ -5544,65 +5551,65 @@ 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); case INST_STR_UPPER: valuePtr = OBJ_AT_TOS; - TRACE(("\"%.20s\" => ", O2S(valuePtr))); + TRACE(("\"%.30s\" => ", 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))); + TRACE_APPEND_OBJ(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))); + TRACE_APPEND_OBJ(valuePtr); NEXT_INST_F0(1, 0); } case INST_STR_LOWER: valuePtr = OBJ_AT_TOS; - TRACE(("\"%.20s\" => ", O2S(valuePtr))); + TRACE(("\"%.30s\" => ", 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))); + TRACE_APPEND_OBJ(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))); + TRACE_APPEND_OBJ(valuePtr); NEXT_INST_F0(1, 0); } case INST_STR_TITLE: valuePtr = OBJ_AT_TOS; - TRACE(("\"%.20s\" => ", O2S(valuePtr))); + TRACE(("\"%.30s\" => ", O2S(valuePtr))); if (Tcl_IsShared(valuePtr)) { s1 = TclGetStringFromObj(valuePtr, &slength); TclNewStringObj(objResultPtr, s1, slength); slength = Tcl_UtfToTitle(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)); Tcl_SetObjLength(valuePtr, slength); TclFreeInternalRep(valuePtr); - TRACE_APPEND(("\"%.20s\"\n", O2S(valuePtr))); + 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. @@ -5642,7 +5649,7 @@ TEBCresume( } } - TRACE_APPEND(("\"%s\"\n", O2S(objResultPtr))); + TRACE_APPEND_OBJ(objResultPtr); NEXT_INST_F(1, 2, 1); case INST_STR_RANGE: @@ -5668,7 +5675,7 @@ 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: @@ -5693,7 +5700,7 @@ TEBCresume( } else { objResultPtr = Tcl_GetRange(valuePtr, fromIdx, toIdx); } - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + TRACE_APPEND_OBJ(objResultPtr); NEXT_INST_F(9, 1, 1); { @@ -5722,7 +5729,7 @@ 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_F0(1, 0); } @@ -5738,7 +5745,7 @@ TEBCresume( if ((fromIdx == 0) && (toIdx == slength)) { TclDecrRefCount(OBJ_AT_TOS); OBJ_AT_TOS = value3Ptr; - TRACE_APPEND(("\"%.30s\"\n", O2S(value3Ptr))); + TRACE_APPEND_OBJ(value3Ptr); NEXT_INST_F0(1, 0); } @@ -5749,11 +5756,11 @@ TEBCresume( /* See [Bug 82e7f67325] */ TclDecrRefCount(OBJ_AT_TOS); OBJ_AT_TOS = value3Ptr; - TRACE_APPEND(("\"%.30s\"\n", O2S(value3Ptr))); + 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: @@ -6315,10 +6322,10 @@ TEBCresume( TRACE_ERROR(interp); goto gotError; } else if (objResultPtr == NULL) { - TRACE_APPEND(("%s\n", O2S(valuePtr))); + 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); } @@ -6481,10 +6488,10 @@ TEBCresume( TRACE_APPEND(("OUT OF MEMORY\n")); goto outOfMemory; } else if (objResultPtr == NULL) { - TRACE_APPEND(("%s\n", O2S(valuePtr))); + 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); } @@ -6529,7 +6536,7 @@ 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); @@ -6538,10 +6545,10 @@ TEBCresume( } 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))); + TRACE_APPEND_NUM_OBJ(valuePtr); NEXT_INST_F0(1, 0); } @@ -6550,7 +6557,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); @@ -6560,7 +6567,7 @@ TEBCresume( switch (type1) { case TCL_NUMBER_NAN: /* -NaN => NaN */ - TRACE_APPEND(("%s\n", O2S(valuePtr))); + TRACE_APPEND_NUM_OBJ(valuePtr); NEXT_INST_F0(1, 0); break; case TCL_NUMBER_INT: @@ -6568,21 +6575,21 @@ TEBCresume( 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))); + TRACE_APPEND_NUM_OBJ(valuePtr); NEXT_INST_F0(1, 0); } /* FALLTHROUGH */ } 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))); + TRACE_APPEND_NUM_OBJ(valuePtr); NEXT_INST_F0(1, 0); } @@ -6744,7 +6751,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; } @@ -6884,7 +6891,7 @@ TEBCresume( if (TclPtrSetVarIdx(interp, varPtr, NULL, NULL, 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; } @@ -6908,7 +6915,6 @@ TEBCresume( */ pc++; #endif - case INST_FOREACH_END: /* THIS INSTRUCTION IS ONLY CALLED AS A BREAK TARGET */ tmpPtr = OBJ_AT_TOS; @@ -6931,7 +6937,7 @@ 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); @@ -6947,8 +6953,8 @@ 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_F0(5, 0); break; @@ -6959,7 +6965,7 @@ TEBCresume( Tcl_ResetResult(interp); CACHE_STACK_INFO(); result = TCL_OK; - TRACE(("=> catchTop=%" TCL_Z_MODIFIER "u\n", (size_t)(catchTop - initCatchTop - 1))); + TRACE(("=> catchTop=%" SIZEd "\n", (Tcl_Size)(catchTop - initCatchTop - 1))); NEXT_INST_F0(1, 0); break; @@ -7125,7 +7131,7 @@ TEBCresume( TRACE_ERROR(interp); goto gotError; } - TRACE_APPEND(("\"%.30s\"\n", O2S(dictPtr))); + TRACE_APPEND_OBJ(dictPtr); if (allocateDict) { objResultPtr = dictPtr; NEXT_INST_V(1, 3, 1); @@ -7145,7 +7151,7 @@ TEBCresume( TRACE_ERROR(interp); goto gotError; } - TRACE_APPEND(("\"%.30s\"\n", O2S(dictPtr))); + TRACE_APPEND_OBJ(dictPtr); if (allocateDict) { objResultPtr = dictPtr; NEXT_INST_F(1, 2, 1); @@ -7161,7 +7167,7 @@ TEBCresume( &OBJ_AT_DEPTH(numArgs - 1), DICT_PATH_READ); if (dictPtr == NULL) { TRACE_APPEND(( - "ERROR tracing dictionary path into \"%.30s\": %s", + "ERROR tracing dictionary path into \"%.30s\": %s\n", O2S(OBJ_AT_DEPTH(numArgs)), O2S(Tcl_GetObjResult(interp)))); goto gotError; @@ -7169,7 +7175,7 @@ TEBCresume( } if (Tcl_DictObjGet(interp, dictPtr, OBJ_AT_TOS, &objResultPtr) != TCL_OK) { - TRACE_APPEND(("ERROR reading leaf dictionary key \"%.30s\": %s", + TRACE_APPEND(("ERROR reading leaf dictionary key \"%.30s\": %s\n", O2S(OBJ_AT_TOS), O2S(Tcl_GetObjResult(interp)))); goto gotError; } @@ -7181,11 +7187,11 @@ TEBCresume( Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT", TclGetString(OBJ_AT_TOS), (char *)NULL); CACHE_STACK_INFO(); - TRACE_APPEND(("ERROR leaf dictionary key \"%.30s\" absent: %s", + 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))); + TRACE_APPEND_OBJ(objResultPtr); NEXT_INST_V(5, numArgs + 1, 1); case INST_DICT_GET_DEF: numArgs = TclGetUInt4AtPtr(pc + 1); @@ -7196,7 +7202,7 @@ TEBCresume( &OBJ_AT_DEPTH(numArgs), DICT_PATH_EXISTS); if (dictPtr == NULL) { TRACE_APPEND(( - "ERROR tracing dictionary path into \"%.30s\": %s", + "ERROR tracing dictionary path into \"%.30s\": %s\n", O2S(OBJ_AT_DEPTH(numArgs + 1)), O2S(Tcl_GetObjResult(interp)))); goto gotError; @@ -7206,14 +7212,14 @@ 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))); + TRACE_APPEND_OBJ(objResultPtr); NEXT_INST_V(5, numArgs + 2, 1); case INST_DICT_SET: @@ -7320,7 +7326,7 @@ 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: @@ -7453,7 +7459,7 @@ TEBCresume( 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: @@ -7678,7 +7684,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: @@ -7839,7 +7845,7 @@ 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_F0(0, 0); @@ -7851,7 +7857,7 @@ 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_F0(0, 0); @@ -8023,9 +8029,9 @@ 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 @@ -8063,10 +8069,9 @@ 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"); } @@ -9289,19 +9294,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, @@ -9313,10 +9316,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, @@ -9327,8 +9329,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); } @@ -9369,7 +9371,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); @@ -9381,7 +9383,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"); } @@ -9389,7 +9391,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; @@ -9612,7 +9615,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; @@ -9766,7 +9769,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) { @@ -9989,9 +9992,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); @@ -10003,7 +10006,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); @@ -10013,7 +10016,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), @@ -10024,7 +10028,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); @@ -10034,7 +10038,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), @@ -10055,17 +10060,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); /* @@ -10102,20 +10107,20 @@ EvalStatsCmd( 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); @@ -10140,7 +10145,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", @@ -10201,7 +10206,7 @@ EvalStatsCmd( for (ui = 0; ui <= maxSizeDecade; ui++) { 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)); } @@ -10234,7 +10239,7 @@ EvalStatsCmd( for (ui = minSizeDecade; ui <= maxSizeDecade; ui++) { 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)); } @@ -10258,7 +10263,7 @@ EvalStatsCmd( for (ui = minSizeDecade; ui <= maxSizeDecade; ui++) { 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)); } @@ -10292,7 +10297,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", -- cgit v0.12 From bb617aa011544d4f1febc019d8e503e8528923c2 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 22 May 2025 14:35:42 +0000 Subject: tidy up spaces --- generic/tclExecute.c | 84 ++++++++++++++++++++++++++-------------------------- 1 file changed, 42 insertions(+), 42 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index d09a56e..a24fbd2 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -124,31 +124,31 @@ typedef struct { } 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) /* @@ -499,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) @@ -539,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))) /* @@ -2861,7 +2861,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); @@ -6858,7 +6858,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(); @@ -8310,26 +8310,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; @@ -9902,13 +9902,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; + (value > 0x7FFFFFFF) ? + 31 : TclMSB((unsigned long long) value) + ) : 0; } /* -- cgit v0.12 From c0d43e104e7227874a6bd40a522a4c25f1b03a6d Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 22 May 2025 19:36:32 +0000 Subject: Clean up the stat buffer renderer a bit --- generic/tclCmdAH.c | 81 ++++++++++++++++++++++++++---------------------------- 1 file changed, 39 insertions(+), 42 deletions(-) diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index baaf949..6e12a29 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -2339,34 +2339,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; @@ -2379,44 +2375,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; -- cgit v0.12 From 86256cad5d7ee285b7afb83c888b6d645a8327d4 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Fri, 23 May 2025 02:18:55 +0000 Subject: Fix [c776eb586d]. Read codepage from registry (reported by Jan) --- win/tclWinInit.c | 141 +++++++++++++++++++++++++++++++++++++++++++++++++------ 1 file changed, 126 insertions(+), 15 deletions(-) diff --git a/win/tclWinInit.c b/win/tclWinInit.c index 8ff0e0e..23aad3e 100644 --- a/win/tclWinInit.c +++ b/win/tclWinInit.c @@ -12,6 +12,7 @@ */ #include "tclWinInt.h" +#include #include #include #include @@ -35,6 +36,12 @@ typedef struct { WORD wReserved; } OemId; +typedef struct { + Tcl_Encoding userEncoding; +} ThreadSpecificData; + +static Tcl_ThreadDataKey dataKey; + /* * The following arrays contain the human readable strings for the * processor values. @@ -119,7 +126,74 @@ static const OSVERSIONINFOW *TclpGetWindowsVersion(void) return result ? osInfoPtr : NULL; } - +/* + * TclpGetCodePageOnce -- + * + * Callback to retrieve user code page. To be invoked only + * through InitOnceExecuteOnce for thread safety. + * + * Results: + * None. + */ +static BOOL CALLBACK +TclpGetCodePageOnce( + TCL_UNUSED(PINIT_ONCE), + TCL_UNUSED(PVOID), + PVOID *lpContext) +{ + static char codePage[20]; + codePage[0] = 'c'; + codePage[1] = 'p'; + DWORD size = sizeof(codePage) - 2; + + /* + * When retrieving code page from registry, + * - use ANSI API's since all values will be ASCII and saves conversion + * - use RegGetValue, not RegQueryValueEx, since the latter does not + * guarantee the value is null terminated + * - added bonus, RegGetValue is much more convenient to use + */ + if (RegGetValueA(HKEY_LOCAL_MACHINE, + "SYSTEM\\CurrentControlSet\\Control\\Nls\\CodePage", + "ACP", RRF_RT_REG_SZ, NULL, codePage+2, + &size) != ERROR_SUCCESS) { + /* On failure, fallback to GetACP() */ + UINT acp = GetACP(); + snprintf(codePage, sizeof(codePage), "cp%u", acp); + } + if (strcmp(codePage, "cp65001") == 0) { + strcpy(codePage, "utf-8"); + } + *lpContext = (LPVOID)&codePage[0]; + return TRUE; +} + +/* + * TclpGetCodePage -- + * + * Returns a pointer to the string identifying the user code page. + * + * For consistency with Windows, which caches the code page at program + * startup, the code page is not updated even if the value in the registry + * changes. (This is similar to environment variables.) + */ +static const char * +TclpGetCodePage(void) +{ + static INIT_ONCE codePageOnce = INIT_ONCE_STATIC_INIT; + const char *codePagePtr = NULL; + BOOL result = InitOnceExecuteOnce( + &codePageOnce, TclpGetCodePageOnce, NULL, (LPVOID *)&codePagePtr); +#ifdef NDEBUG + (void) result; /* Keep gcc unused variable quiet */ +#else + assert(result == TRUE); +#endif + assert(codePagePtr != NULL); + return codePagePtr; +} + + /* *--------------------------------------------------------------------------- * @@ -162,8 +236,11 @@ TclpInitPlatform(void) TclWinInit(GetModuleHandleW(NULL)); #endif + + /* Initialize code page once at startup, will not be updated */ + (void)TclpGetCodePage(); } - + /* *------------------------------------------------------------------------- * @@ -453,21 +530,54 @@ TclpSetInitialEncodings(void) Tcl_DStringFree(&encodingName); } -const char * -Tcl_GetEncodingNameForUser( - Tcl_DString *bufPtr) +#if 0 + +/* + *--------------------------------------------------------------------------- + * + * TclpGetEncodingForUser -- + * + * Returns the Tcl_Encoding corresponding to the user code page. + * + * Results: + * A Tcl_Encoding value or NULL if the encoding cannot be found or + * if Tcl does not support the encoding. + * + * Side effects: + * The encoding is cached in the thread local storage. + *--------------------------------------------------------------------------- + */ +Tcl_Encoding +TclpGetEncodingForUser(Tcl_Interp *interp) { - UINT acp = GetACP(); + /* + * In keeping with Windows, the encoding will not be updated if the + * registry value changes so we never need to update it once + * successfully retrieved. + */ + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + if (tsdPtr->userEncoding == NULL) { + tsdPtr->userEncoding = + Tcl_GetEncoding(interp, TclpGetCodePage()); + } + return tsdPtr->userEncoding; +} - Tcl_DStringInit(bufPtr); - if (acp == CP_UTF8) { - Tcl_DStringAppend(bufPtr, "utf-8", 5); - } else { - Tcl_DStringSetLength(bufPtr, 2 + TCL_INTEGER_SPACE); - snprintf(Tcl_DStringValue(bufPtr), 2 + TCL_INTEGER_SPACE, "cp%d", - acp); - Tcl_DStringSetLength(bufPtr, strlen(Tcl_DStringValue(bufPtr))); +void TclpReleaseEncodingForUser(void) +{ + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + if (tsdPtr->userEncoding) { + Tcl_FreeEncoding(tsdPtr->userEncoding); + tsdPtr->userEncoding = NULL; } +} +#endif + +const char * +Tcl_GetEncodingNameForUser(Tcl_DString *bufPtr) +{ + Tcl_DStringInit(bufPtr); + Tcl_DStringAppend(bufPtr, TclpGetCodePage(), -1); return Tcl_DStringValue(bufPtr); } @@ -484,8 +594,9 @@ Tcl_GetEncodingNameFromEnvironment( Tcl_DStringInit(bufPtr); Tcl_DStringAppend(bufPtr, "utf-8", 5); return Tcl_DStringValue(bufPtr); + } else { + return Tcl_GetEncodingNameForUser(bufPtr); } - return Tcl_GetEncodingNameForUser(bufPtr); } const char * -- cgit v0.12 -- cgit v0.12 From 9aadfdb56c6e990834014f27913cf86a7ff0d1b5 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 23 May 2025 09:03:35 +0000 Subject: Clean up indentation and overlong lines --- generic/tclArithSeries.c | 2 +- generic/tclAssembly.c | 10 +-- generic/tclBasic.c | 16 ++--- generic/tclBinary.c | 29 ++++---- generic/tclCkalloc.c | 17 +++-- generic/tclClock.c | 4 +- generic/tclClockFmt.c | 45 ++++++------ generic/tclCmdIL.c | 52 +++++++------- generic/tclCmdMZ.c | 14 ++-- generic/tclCompCmds.c | 62 ++++++++-------- generic/tclCompCmdsGR.c | 2 +- generic/tclEncoding.c | 102 +++++++++++++------------- generic/tclEvent.c | 2 +- generic/tclExecute.c | 10 +-- generic/tclIO.c | 30 ++++---- generic/tclIOGT.c | 4 +- generic/tclIORChan.c | 31 ++++---- generic/tclIORTrans.c | 4 +- generic/tclIOUtil.c | 3 +- generic/tclIcu.c | 184 +++++++++++++++++++---------------------------- generic/tclIndexObj.c | 10 ++- generic/tclListObj.c | 88 +++++++++++------------ generic/tclObj.c | 56 ++++++++------- generic/tclParse.c | 3 +- generic/tclPathObj.c | 17 ++--- generic/tclPkg.c | 3 +- generic/tclPosixStr.c | 22 ++++-- generic/tclStrToD.c | 8 +-- generic/tclStringObj.c | 6 +- generic/tclTest.c | 101 +++++++++++++++----------- generic/tclTestABSList.c | 168 ++++++++++++++++++++++--------------------- generic/tclTestObj.c | 24 +++---- generic/tclTrace.c | 8 +-- generic/tclUniData.c | 16 +++-- generic/tclUtil.c | 147 ++++++++++++++++++------------------- generic/tclVar.c | 9 +-- macosx/tclMacOSXFCmd.c | 11 +-- unix/tclEpollNotfy.c | 29 ++++---- unix/tclLoadDyld.c | 2 +- unix/tclUnixChan.c | 6 +- unix/tclUnixCompat.c | 2 +- unix/tclUnixFCmd.c | 6 +- unix/tclUnixFile.c | 15 ++-- unix/tclUnixInit.c | 3 +- unix/tclUnixPipe.c | 6 +- unix/tclUnixSock.c | 12 ++-- win/tclWinDde.c | 23 +++--- win/tclWinFile.c | 2 +- win/tclWinPipe.c | 7 +- win/tclWinPort.h | 12 ++-- win/tclWinReg.c | 20 +++--- win/tclWinTest.c | 5 +- win/tclWinThrd.c | 4 +- 53 files changed, 750 insertions(+), 724 deletions(-) diff --git a/generic/tclArithSeries.c b/generic/tclArithSeries.c index dbd3d47..c075369 100755 --- a/generic/tclArithSeries.c +++ b/generic/tclArithSeries.c @@ -728,7 +728,7 @@ TclNewArithSeriesObj( * (0x0ffffffffffffffa instead of 0x7fffffffffffffff by 64bit) */ if (len > TCL_SIZE_MAX) { - exceeded: + exceeded: Tcl_SetObjResult(interp, Tcl_NewStringObj( "max length of a Tcl list exceeded", TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL); diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 8a3e7e7..5ced5b8 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -1377,8 +1377,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]", -1)); Tcl_SetErrorCode(interp, "TCL", "ASSEM", "OPERAND<0,>3", (char *)NULL); goto cleanup; } @@ -1618,8 +1618,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", -1)); Tcl_SetErrorCode(interp, "TCL", "ASSEM", "OPERAND>=2", (char *)NULL); } goto cleanup; @@ -1749,7 +1749,7 @@ AssembleOneLine( } status = TCL_OK; - cleanup: + cleanup: Tcl_DecrRefCount(instNameObj); if (operand1Obj) { Tcl_DecrRefCount(operand1Obj); diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 4bf72a1..e8ff787 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -5574,7 +5574,7 @@ TclEvalEx( Tcl_LogCommandInfo(interp, script, parsePtr->commandStart, commandLength); } - posterror: + posterror: iPtr->flags &= ~ERR_ALREADY_LOGGED; /* @@ -5596,7 +5596,7 @@ TclEvalEx( } iPtr->varFramePtr = savedVarFramePtr; - cleanup_return: + cleanup_return: /* * TIP #280. Release the local CmdFrame, and its contents. */ @@ -8063,16 +8063,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; } @@ -9607,8 +9607,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; diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 1df01b8..cce0ca1 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -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; } diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c index 497392d..a391efd 100644 --- a/generic/tclCkalloc.c +++ b/generic/tclCkalloc.c @@ -812,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; @@ -1256,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; } @@ -1362,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 ecba0c5..d160fb8 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -3474,7 +3474,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; } @@ -4265,7 +4265,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; } diff --git a/generic/tclClockFmt.c b/generic/tclClockFmt.c index 880a1ad..1fcf1fb 100644 --- a/generic/tclClockFmt.c +++ b/generic/tclClockFmt.c @@ -2303,30 +2303,30 @@ ClockGetOrParseScanFormat( tokCnt++; continue; } - word_tok: + word_tok: { - /* try continue with previous word token */ - ClockScanToken *wordTok = tok - 1; + /* try continue with previous word token */ + ClockScanToken *wordTok = tok - 1; + + if (wordTok < scnTok || wordTok->map != &ScnWordTokenMap) { + /* start with new word token */ + wordTok = tok; + wordTok->tokWord.start = p; + wordTok->map = &ScnWordTokenMap; + } - if (wordTok < scnTok || wordTok->map != &ScnWordTokenMap) { - /* start with new word token */ - wordTok = tok; - wordTok->tokWord.start = p; - wordTok->map = &ScnWordTokenMap; - } + do { + if (isspace(UCHAR(*p))) { + fss->scnSpaceCount++; + } + p = Tcl_UtfNext(p); + } while (p < e && *p != '%'); + wordTok->tokWord.end = p; - do { - if (isspace(UCHAR(*p))) { - fss->scnSpaceCount++; + if (wordTok == tok) { + AllocTokenInChain(tok, scnTok, fss->scnTokC, ClockScanToken *); + tokCnt++; } - p = Tcl_UtfNext(p); - } while (p < e && *p != '%'); - wordTok->tokWord.end = p; - - if (wordTok == tok) { - AllocTokenInChain(tok, scnTok, fss->scnTokC, ClockScanToken *); - tokCnt++; - } } break; } @@ -3346,8 +3346,7 @@ ClockGetOrParseFmtFormat( continue; } default: - word_tok: - { + word_tok: { /* try continue with previous word token */ ClockFormatToken *wordTok = tok - 1; @@ -3366,9 +3365,9 @@ ClockGetOrParseFmtFormat( AllocTokenInChain(tok, fmtTok, fss->fmtTokC, ClockFormatToken *); tokCnt++; } - } break; } + } } /* correct count of real used tokens and free mem if desired diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 6184a43..76fd7c1 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -1304,7 +1304,7 @@ TclInfoFrame( break; case TCL_LOCATION_PREBC: - precompiled: + precompiled: /* * Precompiled. Result contains the type as signal, nothing else. */ @@ -3924,7 +3924,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]); @@ -3972,8 +3972,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) { @@ -4045,7 +4045,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) { @@ -4056,13 +4056,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; @@ -4145,8 +4145,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 @@ -4161,19 +4161,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; @@ -4189,14 +4189,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; } @@ -4335,10 +4335,10 @@ Tcl_LseqObjCmd( /* 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; + break; } /* Count needs to be integer, so try to convert if possible */ @@ -4367,7 +4367,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) { @@ -4375,7 +4375,7 @@ Tcl_LseqObjCmd( Tcl_SetObjResult(interp, arithSeriesPtr); } - done: + done: // Free number arguments. while (--value_i>=0) { if (numValues[value_i]) { @@ -4390,8 +4390,8 @@ Tcl_LseqObjCmd( } /* Undef constants */ - #undef zero - #undef one +#undef zero +#undef one return status; } @@ -4452,13 +4452,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]); } } diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 6277f5f..ca813d7 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -1904,7 +1904,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) { @@ -2040,8 +2040,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; @@ -4507,10 +4507,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; diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 9b1b1ce..f0087f8 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -393,9 +393,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; @@ -3610,34 +3612,34 @@ TclPushVarName( 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 (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; + } } } } diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index ef0c855..9e2e801 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -2360,7 +2360,7 @@ TclCompileReturnCmd( */ if (explicitResult) { - CompileWord(envPtr, wordTokenPtr, interp, numWords - 1); + CompileWord(envPtr, wordTokenPtr, interp, numWords - 1); } else { /* * No explict result argument, so default result is empty string. diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 877a950..2710c3f 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -1953,22 +1953,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); @@ -2481,19 +2481,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) /* @@ -2501,20 +2501,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 @@ -2529,19 +2528,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); @@ -2567,7 +2565,7 @@ UtfToUtfProc( * because the UTF-8 sequence is truncated. */ - CHECK_ISOLATEDSURROGATE; + CHECK_ISOLATEDSURROGATE(); if (flags & ENCODING_INPUT) { /* Incomplete bytes for modified UTF-8 target */ @@ -2610,8 +2608,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; @@ -2629,7 +2627,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)) { @@ -2647,7 +2645,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)) { @@ -2664,7 +2662,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)) { @@ -2682,7 +2680,7 @@ UtfToUtfProc( } } else { /* Normal character */ - CHECK_ISOLATEDSURROGATE; + CHECK_ISOLATEDSURROGATE(); } dst += Tcl_UniCharToUtf(ch, dst); @@ -2698,7 +2696,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; diff --git a/generic/tclEvent.c b/generic/tclEvent.c index 9a8069e..b3e3dc2 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -1725,7 +1725,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 7d97fb0..587249f 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -9553,13 +9553,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; } /* diff --git a/generic/tclIO.c b/generic/tclIO.c index c884934..e159110 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -360,7 +360,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 +738,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 +813,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); } @@ -1617,10 +1621,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 +2464,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 +9429,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 +9809,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 +10172,7 @@ DoRead( } if (!bufPtr) { - readErr: - + readErr: UpdateInterest(chanPtr); TclChannelRelease((Tcl_Channel)chanPtr); return -1; diff --git a/generic/tclIOGT.c b/generic/tclIOGT.c index d855b73..15ee36c 100644 --- a/generic/tclIOGT.c +++ b/generic/tclIOGT.c @@ -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; } diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c index 742aae8..e891933 100644 --- a/generic/tclIORChan.c +++ b/generic/tclIORChan.c @@ -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'. ================== @@ -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; @@ -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; } diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c index 10b5074..eba5af5 100644 --- a/generic/tclIORTrans.c +++ b/generic/tclIORTrans.c @@ -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; } diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 774e1d4..a3ac6f3 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -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)) diff --git a/generic/tclIcu.c b/generic/tclIcu.c index 3110281..51334dc 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; } } @@ -1182,9 +1145,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]); @@ -1193,15 +1156,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; @@ -1438,10 +1402,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) { @@ -1485,10 +1449,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) { @@ -1514,9 +1478,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 92aa421..710babb 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -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) : \ + "") /* *---------------------------------------------------------------------- @@ -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); diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 2cc4fb3..ce4ac05 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_) \ @@ -111,7 +110,7 @@ #define LISTREP_SPACE_ONLY_BACK 0x00000008 #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) @@ -199,26 +198,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) /* @@ -640,12 +639,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 +670,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 +701,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__); } @@ -1754,8 +1750,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[] */ diff --git a/generic/tclObj.c b/generic/tclObj.c index 51f19ee..f9fc83f 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -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) { /* @@ -1958,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; } @@ -2011,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; @@ -2034,7 +2038,8 @@ Tcl_GetBooleanFromObj( 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); } /* @@ -2413,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; } @@ -4171,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/tclParse.c b/generic/tclParse.c index 7216e8e..ec9f61c 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -1397,7 +1397,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--; diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index 82287cf..6ed712e 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -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) /* @@ -2606,7 +2607,7 @@ 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/tclPkg.c b/generic/tclPkg.c index 8473010..e30a457 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -101,7 +101,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); 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/tclStrToD.c b/generic/tclStrToD.c index 69aafaa..2378d96 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 5f33950..73e9984 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 */ @@ -2562,8 +2562,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; diff --git a/generic/tclTest.c b/generic/tclTest.c index 3fca0bb..2c876cf 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -597,7 +597,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); @@ -1106,7 +1106,7 @@ TestcmdinfoCmd( 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, @@ -1622,7 +1622,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; } @@ -1643,7 +1644,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; } @@ -1981,7 +1983,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"); @@ -2204,10 +2214,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]; @@ -3838,12 +3848,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"); @@ -4031,8 +4041,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))); @@ -5059,7 +5069,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; @@ -5067,8 +5078,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); } } @@ -5109,16 +5120,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; @@ -5855,7 +5870,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; } @@ -5878,7 +5894,8 @@ Testset2Cmd( 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; } @@ -5886,7 +5903,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; } @@ -6070,8 +6088,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; @@ -6615,9 +6633,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) { @@ -6934,12 +6951,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]; @@ -7773,8 +7792,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) { @@ -8026,8 +8045,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(); @@ -8720,10 +8739,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 b6af82b..6c49559 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); @@ -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; @@ -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,7 +826,8 @@ 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; @@ -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; } /* @@ -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, "8.7-", 0) == NULL) { return TCL_ERROR; } diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index f3f8884..c4412c0 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -202,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; } @@ -252,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])) { @@ -277,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])) { @@ -302,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])) { @@ -1618,10 +1618,10 @@ TestbigdataCmd ( 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; diff --git a/generic/tclTrace.c b/generic/tclTrace.c index 5386d97..eb582e6 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -1794,8 +1794,8 @@ TraceExecutionProc( 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) { @@ -2804,7 +2804,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); @@ -3068,7 +3068,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 612b7a8..275aa41 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 || TCL_MINOR_VERSION > 6 -# 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 || TCL_MINOR_VERSION > 6 -# 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/tclUtil.c b/generic/tclUtil.c index f0ab3d9..42ce39e 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -1103,96 +1103,97 @@ TclScanElement( } while (length) { - if (CHAR_TYPE(*p) != TYPE_NORMAL) { - switch (*p) { - case '{': /* TYPE_BRACE */ + if (CHAR_TYPE(*p) != TYPE_NORMAL) { + switch (*p) { + case '{': /* TYPE_BRACE */ #if COMPAT - braceCount++; + braceCount++; #endif /* COMPAT */ - extra++; /* Escape '{' => '\{' */ - nestingLevel++; - break; - case '}': /* TYPE_BRACE */ + extra++; /* Escape '{' => '\{' */ + nestingLevel++; + break; + case '}': /* TYPE_BRACE */ #if COMPAT - braceCount++; + braceCount++; #endif /* COMPAT */ - extra++; /* Escape '}' => '\}' */ - if (nestingLevel-- < 1) { - /* - * Unbalanced braces! Cannot format with brace quoting. - */ + extra++; /* Escape '}' => '\}' */ + if (nestingLevel-- < 1) { + /* + * Unbalanced braces! Cannot format with brace quoting. + */ - requireEscape = 1; - } - break; - case ']': /* TYPE_CLOSE_BRACK */ - case '"': /* TYPE_SPACE */ + requireEscape = 1; + } + break; + case ']': /* TYPE_CLOSE_BRACK */ + case '"': /* TYPE_SPACE */ #if COMPAT - forbidNone = 1; - extra++; /* Escapes all just prepend a backslash */ - preferEscape = 1; - break; + forbidNone = 1; + extra++; /* Escapes all just prepend a backslash */ + preferEscape = 1; + break; #else - /* FLOW THROUGH */ + /* FLOW THROUGH */ #endif /* COMPAT */ - case '[': /* TYPE_SUBS */ - case '$': /* TYPE_SUBS */ - case ';': /* TYPE_COMMAND_END */ - forbidNone = 1; - extra++; /* Escape sequences all one byte longer. */ + case '[': /* TYPE_SUBS */ + case '$': /* TYPE_SUBS */ + case ';': /* TYPE_COMMAND_END */ + forbidNone = 1; + extra++; /* Escape sequences all one byte longer. */ #if COMPAT - preferBrace = 1; + preferBrace = 1; #endif /* COMPAT */ - break; - case '\\': /* TYPE_SUBS */ - extra++; /* Escape '\' => '\\' */ - if ((length == 1) || ((length == TCL_INDEX_NONE) && (p[1] == '\0'))) { - /* - * Final backslash. Cannot format with brace quoting. - */ - - requireEscape = 1; break; - } - if (p[1] == '\n') { - extra++; /* Escape newline => '\n', one byte longer */ + case '\\': /* TYPE_SUBS */ + extra++; /* Escape '\' => '\\' */ + if ((length == 1) || + ((length == TCL_INDEX_NONE) && (p[1] == '\0'))) { + /* + * Final backslash. Cannot format with brace quoting. + */ + + requireEscape = 1; + break; + } + if (p[1] == '\n') { + extra++; /* Escape newline => '\n', one byte longer */ - /* - * Backslash newline sequence. Brace quoting not permitted. - */ + /* + * Backslash newline sequence. Brace quoting not permitted. + */ - requireEscape = 1; - length -= (length > 0); - p++; - break; - } - if ((p[1] == '{') || (p[1] == '}') || (p[1] == '\\')) { - extra++; /* Escape sequences all one byte longer. */ - length -= (length > 0); - p++; - } - forbidNone = 1; -#if COMPAT - preferBrace = 1; -#endif /* COMPAT */ - break; - case '\0': /* TYPE_SUBS */ - if (length == TCL_INDEX_NONE) { - goto endOfString; - } - /* TODO: Panic on improper encoding? */ - break; - default: - if (TclIsSpaceProcM(*p)) { + requireEscape = 1; + length -= (length > 0); + p++; + break; + } + if ((p[1] == '{') || (p[1] == '}') || (p[1] == '\\')) { + extra++; /* Escape sequences all one byte longer. */ + length -= (length > 0); + p++; + } forbidNone = 1; - extra++; /* Escape sequences all one byte longer. */ #if COMPAT preferBrace = 1; +#endif /* COMPAT */ + break; + case '\0': /* TYPE_SUBS */ + if (length == TCL_INDEX_NONE) { + goto endOfString; + } + /* TODO: Panic on improper encoding? */ + break; + default: + if (TclIsSpaceProcM(*p)) { + forbidNone = 1; + extra++; /* Escape sequences all one byte longer. */ +#if COMPAT + preferBrace = 1; #endif + } + break; } - break; } - } length -= (length > 0); p++; } @@ -2634,8 +2635,8 @@ Tcl_DStringAppend( if (length > (TCL_SIZE_MAX - dsPtr->length - 1)) { Tcl_Panic("max size for a Tcl value (%" TCL_SIZE_MODIFIER - "d bytes) exceeded", - TCL_SIZE_MAX); + "d bytes) exceeded", + TCL_SIZE_MAX); return NULL; /* NOTREACHED */ } newSize = length + dsPtr->length + 1; diff --git a/generic/tclVar.c b/generic/tclVar.c index 9c2c16c..f2bd26b 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -357,8 +357,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; } @@ -2533,7 +2533,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); } } @@ -2655,7 +2656,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); diff --git a/macosx/tclMacOSXFCmd.c b/macosx/tclMacOSXFCmd.c index 7cb9127..0f9f521 100644 --- a/macosx/tclMacOSXFCmd.c +++ b/macosx/tclMacOSXFCmd.c @@ -629,7 +629,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) { @@ -644,9 +645,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; @@ -677,7 +678,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/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/tclLoadDyld.c b/unix/tclLoadDyld.c index 04c98b0..6beef6b 100644 --- a/unix/tclLoadDyld.c +++ b/unix/tclLoadDyld.c @@ -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 ac4734c..7389a3d 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 00b525e..e59b3ee 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')) { 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..529d3f4 100644 --- a/unix/tclUnixSock.c +++ b/unix/tclUnixSock.c @@ -1107,15 +1107,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 +1681,7 @@ Tcl_OpenTcpServerEx( int retry = 0; #define MAXRETRY 10 - repeat: + repeat: if (retry > 0) { if (statePtr != NULL) { TcpCloseProc(statePtr, NULL); diff --git a/win/tclWinDde.c b/win/tclWinDde.c index abec9b2..2ebb8e8 100644 --- a/win/tclWinDde.c +++ b/win/tclWinDde.c @@ -344,7 +344,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; } @@ -1528,8 +1529,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; @@ -1579,8 +1580,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; @@ -1645,8 +1646,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; @@ -1699,8 +1700,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; @@ -1813,8 +1814,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/tclWinFile.c b/win/tclWinFile.c index 7d95853..9c17cc9 100644 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -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); /* diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c index ae4f93f..efbac82 100644 --- a/win/tclWinPipe.c +++ b/win/tclWinPipe.c @@ -680,8 +680,9 @@ TclpCreateTempFile( * 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); @@ -2586,7 +2587,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; } diff --git a/win/tclWinPort.h b/win/tclWinPort.h index 0f22138..f70bfd5 100644 --- a/win/tclWinPort.h +++ b/win/tclWinPort.h @@ -512,12 +512,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 ae02210..c65b484 100644 --- a/win/tclWinReg.c +++ b/win/tclWinReg.c @@ -427,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; @@ -449,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; } @@ -465,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 { @@ -960,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 { @@ -1348,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/tclWinTest.c b/win/tclWinTest.c index eb9966b..fcc86fd 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; 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, -- cgit v0.12 From 0f9b3af70260987371e3209445c1b8f2f27f3b4f Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 23 May 2025 14:51:23 +0000 Subject: Factor out code for describing the args to a method. --- generic/tclOOInfo.c | 79 ++++++++++++++++++----------------------------------- 1 file changed, 27 insertions(+), 52 deletions(-) diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c index aa7d22a..363dab2 100644 --- a/generic/tclOOInfo.c +++ b/generic/tclOOInfo.c @@ -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; @@ -995,7 +998,6 @@ InfoClassConstrCmd( Tcl_Obj *const objv[]) { Proc *procPtr; - CompiledLocal *localPtr; Tcl_Obj *resultObjs[2]; Class *clsPtr; @@ -1019,20 +1021,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; @@ -1057,7 +1046,6 @@ InfoClassDefnCmd( { Tcl_HashEntry *hPtr; Proc *procPtr; - CompiledLocal *localPtr; Tcl_Obj *resultObjs[2]; Class *clsPtr; @@ -1087,20 +1075,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; -- cgit v0.12 From 5d722018bad4420f72308bd15a9f9617661bc5da Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sun, 25 May 2025 17:27:37 +0000 Subject: Start on [7346adc50f]. Now raise error on truncated encoding. Still have to handle replace and tcl8 profiles. --- generic/tclEncoding.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 5842a0b..bdf06c9 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -1228,7 +1228,7 @@ Tcl_ExternalToUtfDStringEx( * and loop. Otherwise, return the result we got. */ if ((result != TCL_CONVERT_NOSPACE) && - !(result == TCL_CONVERT_MULTIBYTE && (flags & TCL_ENCODING_END))) { + (result != TCL_CONVERT_MULTIBYTE || (flags & TCL_ENCODING_END))) { Tcl_Size nBytesProcessed = (src - srcStart); Tcl_DStringSetLength(dstPtr, soFar); -- cgit v0.12 From c4618712a008b8d0377029f7991ee60deba4fb0a Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Mon, 26 May 2025 05:12:10 +0000 Subject: Handle tcl8 and replace profiles for truncated escape encodings. Add tests. --- generic/tclEncoding.c | 26 +++++++++++++++++++++++++- tests/encoding.test | 21 ++++++++++++++++++++- tests/utfext.test | 42 ++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 87 insertions(+), 2 deletions(-) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index bdf06c9..3f26ab7 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -1544,7 +1544,7 @@ Tcl_UtfToExternalDStringEx( * and loop. Otherwise, return the result we got. */ if ((result != TCL_CONVERT_NOSPACE) && - !(result == TCL_CONVERT_MULTIBYTE && (flags & TCL_ENCODING_END))) { + (result != TCL_CONVERT_MULTIBYTE || (flags & TCL_ENCODING_END))) { Tcl_Size nBytesProcessed = (src - srcStart); Tcl_Size i = soFar + encodingPtr->nullSize - 1; /* Loop as DStringSetLength only stores one nul byte at a time */ @@ -4067,6 +4067,30 @@ EscapeToUtfProc( numChars++; } + if ((flags & TCL_ENCODING_END) && (result == TCL_CONVERT_MULTIBYTE)) { + /* We have a code fragment left-over at the end */ + if (dst > dstEnd) { + result = TCL_CONVERT_NOSPACE; + } else { + /* destination is not full, so we really are at the end now */ + if (PROFILE_STRICT(flags)) { + result = TCL_CONVERT_SYNTAX; + } else { + /* + * PROFILE_REPLACE or PROFILE_TCL8. The latter is treated + * similar to former because Tcl8 was broken in this regard + * as it just ignored the byte and truncated which is really + * a no-no as per Unicode recommendations. + */ + result = TCL_OK; + dst += Tcl_UniCharToUtf(UNICODE_REPLACE_CHAR, dst); + numChars++; + /* TCL_CONVERT_MULTIBYTE means all source consumed */ + src = srcEnd; + } + } + } + *statePtr = (Tcl_EncodingState) INT2PTR(state); *srcReadPtr = src - srcStart; *dstWrotePtr = dst - dstStart; diff --git a/tests/encoding.test b/tests/encoding.test index a754f72..b20b18d 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -1057,7 +1057,7 @@ test encoding-27.2 {encoding dirs basic behavior} -returnCodes error -body { encoding dirs "\{not a list" } -result "expected directory list but got \"\{not a list\"" -} +}; # proc runtests test encoding-28.0 {all encodings load} -body { @@ -1194,6 +1194,25 @@ test encoding-bug-201c7a3aa6-tcl8 {Crash encoding non-BMP to iso2022} -body { encoding convertto -profile tcl8 iso2022 \U1f600 } -result ? +test encoding-bug-7346adc50f-strict {OOM on convertfrom truncated iso2022 - strict} -body { + encoding convertfrom -profile strict iso2022-jp "\x1b\$B\$*;n\$" +} -result {unexpected byte sequence starting at index 7: '\x24'} -returnCodes error + +test encoding-bug-7346adc50f-failindex {OOM on convertfrom truncated iso2022 - failindex} -body { + list [encoding convertfrom -failindex failix iso2022-jp "\x1b\$B\$*;n\$"] $failix +} -cleanup { + unset -nocomplain failix +} -result [list \u304A\u8A66 7] + +test encoding-bug-7346adc50f-strict {OOM on convertfrom truncated iso2022 - replace} -body { + encoding convertfrom -profile replace iso2022-jp "\x1b\$B\$*;n\$" +} -result \u304A\u8A66\uFFFD + +test encoding-bug-7346adc50f-tcl8 {OOM on convertfrom truncated iso2022 - tcl8} -body { + encoding convertfrom -profile tcl8 iso2022-jp "\x1b\$B\$*;n\$" +} -result \u304A\u8A66\uFFFD + + # cleanup namespace delete ::tcl::test::encoding ::tcltest::cleanupTests diff --git a/tests/utfext.test b/tests/utfext.test index ca74229..8ab4bc4 100644 --- a/tests/utfext.test +++ b/tests/utfext.test @@ -320,6 +320,48 @@ namespace eval utftest { set result [list [testencoding Tcl_ExternalToUtf shiftjis $src {start tcl8} 0 16 srcRead dstWritten charsWritten] $srcRead $dstWritten $charsWritten] lappend result {*}[list [testencoding Tcl_ExternalToUtf shiftjis [string range $src $srcRead end] {end tcl8} 0 10 srcRead dstWritten charsWritten] $srcRead $dstWritten $charsWritten] } -result [list [list multibyte 0 \xEF\xBC\x90\xEF\xBC\x91\x00\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF] 4 6 2 [list ok 0 \xC2\x82\x00\xFF\xFF\xFF\xFF\xFF\xFF\xFF] 1 2 1] -constraints testencoding + + test Tcl_ExternalToUtf-bug-7346adc50f-strict-0 { + truncated input in escape encoding (strict) + } -body { + set src [binary decode hex 1b2442242a3b6e24] + list {*}[testencoding Tcl_ExternalToUtf iso2022-jp $src {start end strict} 0 16 srcRead dstWritten charsWritten] $srcRead $dstWritten $charsWritten + } -result [list syntax 2 [binary decode hex e3818ae8a9a600ffffffffffffffffff] 7 6 2] + + test Tcl_ExternalToUtf-bug-7346adc50f-strict-1 { + truncated input in escape encoding (strict, partial) + } -body { + set src [binary decode hex 1b2442242a3b6e24] + list {*}[testencoding Tcl_ExternalToUtf iso2022-jp $src {start strict} 0 16 srcRead dstWritten charsWritten] $srcRead $dstWritten $charsWritten + } -result [list multibyte 2 [binary decode hex e3818ae8a9a600ffffffffffffffffff] 7 6 2] + + test Tcl_ExternalToUtf-bug-7346adc50f-replace-0 { + truncated input in escape encoding (replace) + } -body { + set src [binary decode hex 1b2442242a3b6e24] + list {*}[testencoding Tcl_ExternalToUtf iso2022-jp $src {start end replace} 0 16 srcRead dstWritten charsWritten] $srcRead $dstWritten $charsWritten + } -result [list ok 2 [binary decode hex e3818ae8a9a6efbfbd00ffffffffffff] 8 9 3] + + test Tcl_ExternalToUtf-bug-7346adc50f-replace-1 { + truncated input in escape encoding (replace, partial) + } -body { + set src [binary decode hex 1b2442242a3b6e24] + list {*}[testencoding Tcl_ExternalToUtf iso2022-jp $src {start replace} 0 16 srcRead dstWritten charsWritten] $srcRead $dstWritten $charsWritten + } -result [list multibyte 2 [binary decode hex e3818ae8a9a600ffffffffffffffffff] 7 6 2] + + test Tcl_ExternalToUtf-bug-7346adc50f-tcl8-0 { + truncated input in escape encoding (tcl8) + } -body { + set src [binary decode hex 1b2442242a3b6e24] + list {*}[testencoding Tcl_ExternalToUtf iso2022-jp $src {start end tcl8} 0 16 srcRead dstWritten charsWritten] $srcRead $dstWritten $charsWritten + } -result [list ok 2 [binary decode hex e3818ae8a9a6efbfbd00ffffffffffff] 8 9 3] + + test Tcl_ExternalToUtf-bug-7346adc50f-tcl8-1 { + truncated input in escape encoding (tcl8, partial) + } -body { + set src [binary decode hex 1b2442242a3b6e24] + list {*}[testencoding Tcl_ExternalToUtf iso2022-jp $src {start tcl8} 0 16 srcRead dstWritten charsWritten] $srcRead $dstWritten $charsWritten + } -result [list multibyte 2 [binary decode hex e3818ae8a9a600ffffffffffffffffff] 7 6 2] } namespace delete utftest -- cgit v0.12 From 9087f5508221aa8a81802d3a7c5aedf325246c20 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Mon, 26 May 2025 06:12:50 +0000 Subject: Add table driven truncation at end test --- tests/utfext.test | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/tests/utfext.test b/tests/utfext.test index 8ab4bc4..bfbb2db 100644 --- a/tests/utfext.test +++ b/tests/utfext.test @@ -185,7 +185,7 @@ namespace eval utftest { set out [binary decode hex $hexout] set dstlen 40 ;# Should be enough for all encoding tests - test $cmd-$enc-$id "$cmd - $enc - $hexin - frag" -constraints testencoding -body { + test $cmd-$enc-$id-0 "$cmd - $enc - $hexin - frag=$fragindex" -constraints testencoding -body { set frag1Result [testencoding $cmd $enc [string range $in 0 $fragindex-1] {start} 0 $dstlen frag1Read frag1Written] lassign $frag1Result frag1Status frag1State frag1Decoded set frag2Result [testencoding $cmd $enc [string range $in $frag1Read end] {end} $frag1State $dstlen frag2Read frag2Written] @@ -195,6 +195,16 @@ namespace eval utftest { $frag2Status [expr {$frag1Read+$frag2Read}] \ [expr {$frag1Written+$frag2Written}] $decoded } -result [list $status1 1 ok [string length $in] [string length $out] $out] + + if {$direction eq "toutf"} { + # Fragmentation but with no more data. + # Only check status. Content output is already checked in above test. + test $cmd-$enc-$id-1 "$cmd - $enc - $hexin - frag=$fragindex - no more data" -constraints testencoding -body { + set frag1Result [testencoding $cmd $enc [string range $in 0 $fragindex-1] {start end} 0 $dstlen frag1Read frag1Written] + lassign $frag1Result frag1Status frag1State frag1Decoded + set frag1Status + } -result syntax + } } proc testcharlimit {direction enc comment hexin hexout} { -- cgit v0.12 From efc03cf36fc4a278e432178fe2a2cac9a8d0b0a4 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 26 May 2025 10:04:29 +0000 Subject: Use TclAttemptInitStringRep() in a few more places where it's possible. Fix indenting. --- generic/tcl.h | 4 ++-- generic/tclAssembly.c | 8 ++++---- generic/tclCompCmds.c | 4 ++-- generic/tclCompCmdsGR.c | 2 +- generic/tclCompCmdsSZ.c | 2 +- generic/tclCompExpr.c | 15 ++++++++++----- generic/tclCompile.c | 2 +- generic/tclDictObj.c | 2 +- generic/tclExecute.c | 2 +- generic/tclInt.h | 4 ++-- generic/tclListObj.c | 4 +++- generic/tclLiteral.c | 5 +++-- generic/tclOOInfo.c | 2 +- generic/tclOptimize.c | 2 +- generic/tclStringObj.c | 5 ++++- generic/tclUtil.c | 4 ++-- 16 files changed, 39 insertions(+), 28 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index 00f073c..279f481 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2413,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); } } } diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 85cd5c0..7d0d47c 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -1509,7 +1509,7 @@ AssembleOneLine( Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADJUMPTABLE", (char *)NULL); goto cleanup; } - + if (TalInstructionTable[tblIdx].tclInstCode == INST_JUMP_TABLE) { JumptableInfo* jtPtr = AllocJumptable(); @@ -3092,11 +3092,11 @@ ResolveJumpTableTargets( 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( @@ -3105,7 +3105,7 @@ ResolveJumpTableTargets( (Tcl_Size) Tcl_GetHashKey(symHash, symEntryPtr), TclGetString(symbolObj), jumpTargetBBPtr, jumpTargetBBPtr->startOffset, realJumpEntryPtr); - + Tcl_SetHashValue(realJumpEntryPtr, INT2PTR(jumpTargetBBPtr->startOffset - bbPtr->jumpOffset)); } diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 6189eb7..2773188 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -450,8 +450,8 @@ TclCompileArraySetCmd( OP4( STORE_ARRAY, localIndex); OP( POP); infoPtr->loopCtTemp = offsetBack - CurrentOffset(envPtr); /*misuse */ - OP( FOREACH_STEP); - OP( FOREACH_END); + OP( FOREACH_STEP); + OP( FOREACH_END); STKDELTA(-3); PUSH( ""); diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index f8390cf..3b4ef4a 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -831,7 +831,7 @@ TclCompileLappendCmd( varTokenPtr = TokenAfter(parsePtr->tokenPtr); PushVarNameWord(varTokenPtr, 0, &localIndex, &isScalar, 1); - + /* * 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. diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 02fcc4d..bf66484 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -1927,7 +1927,7 @@ TclCompileSwitchCmd( /* * 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. + * twice per arm. */ while (numBytes > 0) { diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 0b5e69e..cb15eec 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -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,7 +733,7 @@ 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 { /* @@ -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) ? "" : "..."); @@ -2085,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); diff --git a/generic/tclCompile.c b/generic/tclCompile.c index bdc6298..f0c2ca2 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -161,7 +161,7 @@ InstructionDesc const tclInstructionTable[] = { "incrScalarStkImm",2, 0, OPERAND_INT1), /* Incr scalar; scalar name is stktop; incr amount is op1 */ DEPRECATED_INSTRUCTION_ENTRY2( - "incrArray1Imm", 3, 0, OPERAND_LVT1, OPERAND_INT1), + "incrArray1Imm", 3, 0, OPERAND_LVT1, OPERAND_INT1), /* Incr array elem; array at slot op1 <= 255, elem is stktop, * amount is 2nd operand byte */ TCL_INSTRUCTION_ENTRY1( diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 0d0a9e2..ae214d2 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -1472,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; diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 53f894f..dcc0584 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -3710,7 +3710,7 @@ TEBCresume( TclNewIntObj(incrPtr, increment); Tcl_IncrRefCount(incrPtr); pcAdjustment = 3; - goto doIncrArray; + goto doIncrArray; #endif case INST_INCR_ARRAY_IMM: diff --git a/generic/tclInt.h b/generic/tclInt.h index dc915e5..3072b57 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4385,7 +4385,7 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, * * MODULE_SCOPE void TclInitEmptyStringRep(Tcl_Obj *objPtr); * MODULE_SCOPE void TclInitStringRep(Tcl_Obj *objPtr, char *bytePtr, size_t len); - * MODULE_SCOPE void TclAttemptInitStringRep(Tcl_Obj *objPtr, char *bytePtr, size_t len); + * MODULE_SCOPE const char *TclAttemptInitStringRep(Tcl_Obj *objPtr, char *bytePtr, size_t len); * *---------------------------------------------------------------- */ @@ -4410,7 +4410,7 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, (objPtr)->bytes = (char *)Tcl_AttemptAlloc((len) + 1U), \ (objPtr)->length = ((objPtr)->bytes) ? \ (memcpy((objPtr)->bytes, (bytePtr) ? (bytePtr) : &tclEmptyString, (len)), \ - (objPtr)->bytes[len] = '\0', (len)) : (-1) \ + (objPtr)->bytes[len] = '\0', (Tcl_Size)(len)) : (-1) \ )), (objPtr)->bytes) /* diff --git a/generic/tclListObj.c b/generic/tclListObj.c index ce4ac05..3223c3c 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -201,7 +201,7 @@ const Tcl_ObjType tclListType = { #define ListObjStompRep(objPtr_, repPtr_) \ do { \ (objPtr_)->internalRep.twoPtrValue.ptr1 = (repPtr_)->storePtr; \ - (objPtr_)->internalRep.twoPtrValue.ptr2 = (repPtr_)->spanPtr; \ + (objPtr_)->internalRep.twoPtrValue.ptr2 = (repPtr_)->spanPtr; \ (objPtr_)->typePtr = &tclListType; \ } while (0) @@ -1193,6 +1193,7 @@ Tcl_DbNewListObj( * *------------------------------------------------------------------------ */ +#if 0 Tcl_Obj * TclNewListObj2( Tcl_Size objc1, /* Count of objects referenced by objv1. */ @@ -1226,6 +1227,7 @@ TclNewListObj2( storePtr->numUsed = objc; return listObj; } +#endif /* *---------------------------------------------------------------------- diff --git a/generic/tclLiteral.c b/generic/tclLiteral.c index bdb2dfe..a1dbc03 100644 --- a/generic/tclLiteral.c +++ b/generic/tclLiteral.c @@ -250,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? */ diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c index 363dab2..2ea7cbd 100644 --- a/generic/tclOOInfo.c +++ b/generic/tclOOInfo.c @@ -110,7 +110,7 @@ DescribeMethodArgs( localPtr=localPtr->nextPtr) { if (TclIsVarArgument(localPtr)) { Tcl_Obj *argObj; - + TclNewObj(argObj); Tcl_ListObjAppendElement(NULL, argObj, Tcl_NewStringObj( localPtr->name, localPtr->nameLength)); diff --git a/generic/tclOptimize.c b/generic/tclOptimize.c index 75cade0..0ff20f9 100644 --- a/generic/tclOptimize.c +++ b/generic/tclOptimize.c @@ -516,7 +516,7 @@ TclOptimizeBytecode( { CompileEnv *realEnvPtr = (CompileEnv *) envPtr; ConvertZeroEffectToNOP(realEnvPtr); - BetterEqualityTesting(realEnvPtr); + BetterEqualityTesting(realEnvPtr); AdvanceJumps(realEnvPtr); TrimUnreachable(realEnvPtr); } diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 73e9984..93d0981 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -302,7 +302,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 */ diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 42ce39e..6ae923a 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -4671,9 +4671,9 @@ TclMSB( * clzll() = Count of Leading Zeroes in a Long Long * NOTE: we rely on input constraint (n != 0). */ - + return 63 - __builtin_clzll(n); - + #else /* -- cgit v0.12 From 352041bd8313f05bf9c04c1300067d318075b0ea Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 26 May 2025 11:37:48 +0000 Subject: Indenting (backported from 9.1) --- generic/tclExecute.c | 4 +- generic/tclHash.c | 2 - generic/tclInt.h | 17 ++-- generic/tclInterp.c | 4 +- generic/tclUtil.c | 267 ++++++++++++++++++++++++++------------------------- 5 files changed, 149 insertions(+), 145 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index a1121ab..37d5041 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -937,8 +937,8 @@ static inline int wordSkip( void *ptr) { - int mask = TCL_ALLOCALIGN-1; - int base = PTR2INT(ptr) & mask; + size_t mask = TCL_ALLOCALIGN-1; + size_t base = PTR2UINT(ptr) & mask; return (TCL_ALLOCALIGN - base)/sizeof(Tcl_Obj *); } diff --git a/generic/tclHash.c b/generic/tclHash.c index 7e2a876..4db576e 100644 --- a/generic/tclHash.c +++ b/generic/tclHash.c @@ -238,8 +238,6 @@ FindHashEntry( *---------------------------------------------------------------------- */ -#define TCL_HASH_FIND ((int *)-1) - static Tcl_HashEntry * CreateHashEntry( Tcl_HashTable *tablePtr, /* Table in which to lookup entry. */ diff --git a/generic/tclInt.h b/generic/tclInt.h index 75608ae..9231087 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -751,6 +751,8 @@ typedef struct VarInHash { #define VAR_IS_ARGS 0x400 #define VAR_RESOLVED 0x8000 +#define TCL_HASH_FIND ((int *)-1) + /* * Macros to ensure that various flag bits are set properly for variables. * The ANSI C "prototypes" for these macros are: @@ -1432,7 +1434,7 @@ typedef struct CFWordBC { typedef struct ContLineLoc { Tcl_Size num; /* Number of entries in loc, not counting the * final -1 marker entry. */ - Tcl_Size loc[TCLFLEXARRAY];/* Table of locations, as character offsets. + Tcl_Size loc[TCLFLEXARRAY]; /* Table of locations, as character offsets. * The table is allocated as part of the * structure, extending behind the nominal end * of the structure. An entry containing the @@ -4012,9 +4014,10 @@ MODULE_SCOPE Tcl_Obj * TclStringReplace(Tcl_Interp *interp, Tcl_Obj *objPtr, MODULE_SCOPE Tcl_Obj * TclStringReverse(Tcl_Obj *objPtr, int flags); /* Flag values for the [string] ensemble functions. */ - -#define TCL_STRING_MATCH_NOCASE TCL_MATCH_NOCASE /* (1<<0) in tcl.h */ -#define TCL_STRING_IN_PLACE (1<<1) +enum StringOpFlags { + TCL_STRING_MATCH_NOCASE = TCL_MATCH_NOCASE, /* (1<<0) in tcl.h */ + TCL_STRING_IN_PLACE = (1<<1) /* Do in-place surgery on Tcl_Obj */ +}; /* * Functions defined in generic/tclVar.c and currently exported only for use @@ -4418,7 +4421,7 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, * * MODULE_SCOPE void TclInitEmptyStringRep(Tcl_Obj *objPtr); * MODULE_SCOPE void TclInitStringRep(Tcl_Obj *objPtr, char *bytePtr, size_t len); - * MODULE_SCOPE void TclAttemptInitStringRep(Tcl_Obj *objPtr, char *bytePtr, size_t len); + * MODULE_SCOPE const char *TclAttemptInitStringRep(Tcl_Obj *objPtr, char *bytePtr, size_t len); * *---------------------------------------------------------------- */ @@ -4443,7 +4446,7 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, (objPtr)->bytes = (char *)Tcl_AttemptAlloc((len) + 1U), \ (objPtr)->length = ((objPtr)->bytes) ? \ (memcpy((objPtr)->bytes, (bytePtr) ? (bytePtr) : &tclEmptyString, (len)), \ - (objPtr)->bytes[len] = '\0', (len)) : (-1) \ + (objPtr)->bytes[len] = '\0', (Tcl_Size)(len)) : (-1) \ )), (objPtr)->bytes) /* @@ -4546,7 +4549,7 @@ MODULE_SCOPE const TclFileAttrProcs tclpFileAttrProcs[]; do { \ Tcl_Obj *bignumObj = (objPtr); \ int bignumPayload = \ - PTR2INT(bignumObj->internalRep.twoPtrValue.ptr2); \ + (int)PTR2INT(bignumObj->internalRep.twoPtrValue.ptr2); \ if (bignumPayload == -1) { \ (bignum) = *((mp_int *) bignumObj->internalRep.twoPtrValue.ptr1); \ } else { \ diff --git a/generic/tclInterp.c b/generic/tclInterp.c index 8ccaa65..91e9814 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -340,8 +340,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 PkgName_ { + struct PkgName_ *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. */ diff --git a/generic/tclUtil.c b/generic/tclUtil.c index bab734e..385a966 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -1056,7 +1056,7 @@ TclScanElement( Tcl_Size extra = 0; /* Count of number of extra bytes needed for * formatted element, assuming we use escape * sequences in formatting. */ - Tcl_Size bytesNeeded; /* Buffer length computed to complete the + Tcl_Size bytesNeeded; /* Buffer length computed to complete the * element formatting in the selected mode. */ #if COMPAT int preferEscape = 0; /* Use preferences to track whether to use */ @@ -1103,96 +1103,97 @@ TclScanElement( } while (length) { - if (CHAR_TYPE(*p) != TYPE_NORMAL) { - switch (*p) { - case '{': /* TYPE_BRACE */ + if (CHAR_TYPE(*p) != TYPE_NORMAL) { + switch (*p) { + case '{': /* TYPE_BRACE */ #if COMPAT - braceCount++; + braceCount++; #endif /* COMPAT */ - extra++; /* Escape '{' => '\{' */ - nestingLevel++; - break; - case '}': /* TYPE_BRACE */ + extra++; /* Escape '{' => '\{' */ + nestingLevel++; + break; + case '}': /* TYPE_BRACE */ #if COMPAT - braceCount++; + braceCount++; #endif /* COMPAT */ - extra++; /* Escape '}' => '\}' */ - if (nestingLevel-- < 1) { - /* - * Unbalanced braces! Cannot format with brace quoting. - */ + extra++; /* Escape '}' => '\}' */ + if (nestingLevel-- < 1) { + /* + * Unbalanced braces! Cannot format with brace quoting. + */ - requireEscape = 1; - } - break; - case ']': /* TYPE_CLOSE_BRACK */ - case '"': /* TYPE_SPACE */ + requireEscape = 1; + } + break; + case ']': /* TYPE_CLOSE_BRACK */ + case '"': /* TYPE_SPACE */ #if COMPAT - forbidNone = 1; - extra++; /* Escapes all just prepend a backslash */ - preferEscape = 1; - break; + forbidNone = 1; + extra++; /* Escapes all just prepend a backslash */ + preferEscape = 1; + break; #else - /* FLOW THROUGH */ + /* FLOW THROUGH */ #endif /* COMPAT */ - case '[': /* TYPE_SUBS */ - case '$': /* TYPE_SUBS */ - case ';': /* TYPE_COMMAND_END */ - forbidNone = 1; - extra++; /* Escape sequences all one byte longer. */ + case '[': /* TYPE_SUBS */ + case '$': /* TYPE_SUBS */ + case ';': /* TYPE_COMMAND_END */ + forbidNone = 1; + extra++; /* Escape sequences all one byte longer. */ #if COMPAT - preferBrace = 1; + preferBrace = 1; #endif /* COMPAT */ - break; - case '\\': /* TYPE_SUBS */ - extra++; /* Escape '\' => '\\' */ - if ((length == 1) || ((length == TCL_INDEX_NONE) && (p[1] == '\0'))) { - /* - * Final backslash. Cannot format with brace quoting. - */ - - requireEscape = 1; break; - } - if (p[1] == '\n') { - extra++; /* Escape newline => '\n', one byte longer */ + case '\\': /* TYPE_SUBS */ + extra++; /* Escape '\' => '\\' */ + if ((length == 1) || + ((length == TCL_INDEX_NONE) && (p[1] == '\0'))) { + /* + * Final backslash. Cannot format with brace quoting. + */ + + requireEscape = 1; + break; + } + if (p[1] == '\n') { + extra++; /* Escape newline => '\n', one byte longer */ - /* - * Backslash newline sequence. Brace quoting not permitted. - */ + /* + * Backslash newline sequence. Brace quoting not permitted. + */ - requireEscape = 1; - length -= (length > 0); - p++; - break; - } - if ((p[1] == '{') || (p[1] == '}') || (p[1] == '\\')) { - extra++; /* Escape sequences all one byte longer. */ - length -= (length > 0); - p++; - } - forbidNone = 1; -#if COMPAT - preferBrace = 1; -#endif /* COMPAT */ - break; - case '\0': /* TYPE_SUBS */ - if (length == TCL_INDEX_NONE) { - goto endOfString; - } - /* TODO: Panic on improper encoding? */ - break; - default: - if (TclIsSpaceProcM(*p)) { + requireEscape = 1; + length -= (length > 0); + p++; + break; + } + if ((p[1] == '{') || (p[1] == '}') || (p[1] == '\\')) { + extra++; /* Escape sequences all one byte longer. */ + length -= (length > 0); + p++; + } forbidNone = 1; - extra++; /* Escape sequences all one byte longer. */ #if COMPAT preferBrace = 1; +#endif /* COMPAT */ + break; + case '\0': /* TYPE_SUBS */ + if (length == TCL_INDEX_NONE) { + goto endOfString; + } + /* TODO: Panic on improper encoding? */ + break; + default: + if (TclIsSpaceProcM(*p)) { + forbidNone = 1; + extra++; /* Escape sequences all one byte longer. */ +#if COMPAT + preferBrace = 1; #endif + } + break; } - break; } - } length -= (length > 0); p++; } @@ -1343,9 +1344,9 @@ TclScanElement( Tcl_Size Tcl_ConvertElement( - const char *src, /* Source information for list element. */ - char *dst, /* Place to put list-ified element. */ - int flags) /* Flags produced by Tcl_ScanElement. */ + const char *src, /* Source information for list element. */ + char *dst, /* Place to put list-ified element. */ + int flags) /* Flags produced by Tcl_ScanElement. */ { return Tcl_ConvertCountedElement(src, TCL_INDEX_NONE, dst, flags); } @@ -1373,7 +1374,7 @@ Tcl_ConvertElement( Tcl_Size Tcl_ConvertCountedElement( - const char *src, /* Source information for list element. */ + const char *src, /* Source information for list element. */ Tcl_Size length, /* Number of bytes in src, or TCL_INDEX_NONE. */ char *dst, /* Place to put list-ified element. */ int flags) /* Flags produced by Tcl_ScanElement. */ @@ -1406,7 +1407,7 @@ Tcl_ConvertCountedElement( Tcl_Size TclConvertElement( - const char *src, /* Source information for list element. */ + const char *src, /* Source information for list element. */ Tcl_Size length, /* Number of bytes in src, or TCL_INDEX_NONE. */ char *dst, /* Place to put list-ified element. */ int flags) /* Flags produced by Tcl_ScanElement. */ @@ -1587,7 +1588,7 @@ TclConvertElement( char * Tcl_Merge( - Tcl_Size argc, /* How many strings to merge. */ + Tcl_Size argc, /* How many strings to merge. */ const char *const *argv) /* Array of string values. */ { #define LOCAL_SIZE 64 @@ -1632,7 +1633,9 @@ Tcl_Merge( result = (char *)Tcl_Alloc(bytesNeeded); dst = result; for (i = 0; i < argc; i++) { - flagPtr[i] |= ( i ? DONT_QUOTE_HASH : 0 ); + if (i) { + flagPtr[i] |= DONT_QUOTE_HASH; + } dst += TclConvertElement(argv[i], TCL_INDEX_NONE, dst, flagPtr[i]); *dst = ' '; dst++; @@ -1664,14 +1667,14 @@ Tcl_Merge( Tcl_Size TclTrimRight( - const char *bytes, /* String to be trimmed... */ - Tcl_Size numBytes, /* ...and its length in bytes */ - /* Calls to TclUtfToUniChar() in this routine - * rely on (bytes[numBytes] == '\0'). */ - const char *trim, /* String of trim characters... */ - Tcl_Size numTrim) /* ...and its length in bytes */ - /* Calls to TclUtfToUniChar() in this routine - * rely on (trim[numTrim] == '\0'). */ + const char *bytes, /* String to be trimmed... */ + Tcl_Size numBytes, /* ...and its length in bytes */ + /* Calls to TclUtfToUniChar() in this routine + * rely on (bytes[numBytes] == '\0'). */ + const char *trim, /* String of trim characters... */ + Tcl_Size numTrim) /* ...and its length in bytes */ + /* Calls to TclUtfToUniChar() in this routine + * rely on (trim[numTrim] == '\0'). */ { const char *pp, *p = bytes + numBytes; int ch1, ch2; @@ -1743,14 +1746,14 @@ TclTrimRight( Tcl_Size TclTrimLeft( - const char *bytes, /* String to be trimmed... */ - Tcl_Size numBytes, /* ...and its length in bytes */ - /* Calls to TclUtfToUniChar() in this routine - * rely on (bytes[numBytes] == '\0'). */ - const char *trim, /* String of trim characters... */ - Tcl_Size numTrim) /* ...and its length in bytes */ - /* Calls to TclUtfToUniChar() in this routine - * rely on (trim[numTrim] == '\0'). */ + const char *bytes, /* String to be trimmed... */ + Tcl_Size numBytes, /* ...and its length in bytes */ + /* Calls to TclUtfToUniChar() in this routine + * rely on (bytes[numBytes] == '\0'). */ + const char *trim, /* String of trim characters... */ + Tcl_Size numTrim) /* ...and its length in bytes */ + /* Calls to TclUtfToUniChar() in this routine + * rely on (trim[numTrim] == '\0'). */ { const char *p = bytes; int ch1, ch2; @@ -1817,14 +1820,14 @@ TclTrimLeft( Tcl_Size TclTrim( - const char *bytes, /* String to be trimmed... */ - Tcl_Size numBytes, /* ...and its length in bytes */ - /* Calls in this routine - * rely on (bytes[numBytes] == '\0'). */ - const char *trim, /* String of trim characters... */ - Tcl_Size numTrim, /* ...and its length in bytes */ - /* Calls in this routine - * rely on (trim[numTrim] == '\0'). */ + const char *bytes, /* String to be trimmed... */ + Tcl_Size numBytes, /* ...and its length in bytes */ + /* Calls in this routine + * rely on (bytes[numBytes] == '\0'). */ + const char *trim, /* String of trim characters... */ + Tcl_Size numTrim, /* ...and its length in bytes */ + /* Calls in this routine + * rely on (trim[numTrim] == '\0'). */ Tcl_Size *trimRightPtr) /* Offset from the end of the string. */ { Tcl_Size trimLeft = 0, trimRight = 0; @@ -1879,7 +1882,7 @@ TclTrim( char * Tcl_Concat( - Tcl_Size argc, /* Number of strings to concatenate. */ + Tcl_Size argc, /* Number of strings to concatenate. */ const char *const *argv) /* Array of strings to concatenate. */ { Tcl_Size i, needSpace = 0, bytesNeeded = 0; @@ -2126,8 +2129,8 @@ Tcl_StringCaseMatch( * characters. */ int nocase) /* 0 for case sensitive, 1 for insensitive */ { - int p, charLen; - int ch1 = 0, ch2 = 0; + Tcl_Size charLen; + int p, ch1 = 0, ch2 = 0; while (1) { p = *pattern; @@ -2357,11 +2360,11 @@ Tcl_StringCaseMatch( int TclByteArrayMatch( const unsigned char *string,/* String. */ - Tcl_Size strLen, /* Length of String */ + Tcl_Size strLen, /* Length of String */ const unsigned char *pattern, /* Pattern, which may contain special * characters. */ - Tcl_Size ptnLen, /* Length of Pattern */ + Tcl_Size ptnLen, /* Length of Pattern */ TCL_UNUSED(int) /*flags*/) { const unsigned char *stringEnd, *patternEnd; @@ -2632,8 +2635,8 @@ Tcl_DStringAppend( if (length > (TCL_SIZE_MAX - dsPtr->length - 1)) { Tcl_Panic("max size for a Tcl value (%" TCL_SIZE_MODIFIER - "d bytes) exceeded", - TCL_SIZE_MAX); + "d bytes) exceeded", + TCL_SIZE_MAX); return NULL; /* NOTREACHED */ } newSize = length + dsPtr->length + 1; @@ -2775,7 +2778,7 @@ Tcl_DStringAppendElement( memcpy(newString, dsPtr->string, dsPtr->length); dsPtr->string = newString; } else { - int offset = -1; + Tcl_Size offset = -1; /* See [16896d49fd] */ if (element >= dsPtr->string @@ -2829,7 +2832,7 @@ Tcl_DStringAppendElement( void Tcl_DStringSetLength( Tcl_DString *dsPtr, /* Structure describing dynamic string. */ - Tcl_Size length) /* New length for dynamic string. */ + Tcl_Size length) /* New length for dynamic string. */ { Tcl_Size newsize; @@ -3318,7 +3321,7 @@ Tcl_Size TclFormatInt( char *buffer, /* Points to the storage into which the * formatted characters are written. */ - Tcl_WideInt n) /* The integer to format. */ + Tcl_WideInt n) /* The integer to format. */ { Tcl_WideUInt intVal; int i = 0, numFormatted, j; @@ -3380,14 +3383,14 @@ TclFormatInt( static int GetWideForIndex( - Tcl_Interp *interp, /* Interpreter to use for error reporting. If + Tcl_Interp *interp, /* Interpreter to use for error reporting. If * NULL, then no error message is left after * errors. */ - Tcl_Obj *objPtr, /* Points to the value to be parsed */ - Tcl_WideInt endValue, /* The value to be stored at *widePtr if + Tcl_Obj *objPtr, /* Points to the value to be parsed */ + Tcl_WideInt endValue, /* The value to be stored at *widePtr if * objPtr holds "end". * NOTE: this value may be TCL_INDEX_NONE. */ - Tcl_WideInt *widePtr) /* Location filled in with a wide integer + Tcl_WideInt *widePtr) /* Location filled in with a wide integer * representing an index. */ { int numType; @@ -3515,10 +3518,10 @@ Tcl_GetIntForIndex( static int GetEndOffsetFromObj( Tcl_Interp *interp, - Tcl_Obj *objPtr, /* Pointer to the object to parse */ - Tcl_WideInt endValue, /* The value to be stored at "widePtr" if + Tcl_Obj *objPtr, /* Pointer to the object to parse */ + Tcl_WideInt endValue, /* The value to be stored at "widePtr" if * "objPtr" holds "end". */ - Tcl_WideInt *widePtr) /* Location filled in with an integer + Tcl_WideInt *widePtr) /* Location filled in with an integer * representing an index. */ { Tcl_ObjInternalRep *irPtr; @@ -3814,11 +3817,11 @@ GetEndOffsetFromObj( int TclIndexEncode( - Tcl_Interp *interp, /* For error reporting, may be NULL */ - Tcl_Obj *objPtr, /* Index value to parse */ - int before, /* Value to return for index before beginning */ - int after, /* Value to return for index after end */ - int *indexPtr) /* Where to write the encoded answer, not NULL */ + Tcl_Interp *interp, /* For error reporting, may be NULL */ + Tcl_Obj *objPtr, /* Index value to parse */ + int before, /* Value to return for index before beginning */ + int after, /* Value to return for index after end */ + int *indexPtr) /* Where to write the encoded answer, not NULL */ { Tcl_WideInt wide; int idx; @@ -3901,7 +3904,7 @@ TclIndexEncode( idx = (int)wide; } } else { - /* objPtr is not purely numeric (end etc.) */ + /* objPtr is not purely numeric (end etc.) */ /* * On 64-bit systems, indices in the range end-LIST_MAX:end-INT_MAX @@ -3960,8 +3963,8 @@ rangeerror: Tcl_Size TclIndexDecode( - int encoded, /* Value to decode */ - Tcl_Size endValue) /* Meaning of "end" to use, > TCL_INDEX_END */ + int encoded, /* Value to decode */ + Tcl_Size endValue) /* Meaning of "end" to use, > TCL_INDEX_END */ { if (encoded > TCL_INDEX_END) { return encoded; @@ -3990,8 +3993,8 @@ TclIndexDecode( */ int TclCommandWordLimitError( - Tcl_Interp *interp, /* May be NULL */ - Tcl_Size count) /* If <= 0, "unknown" */ + Tcl_Interp *interp, /* May be NULL */ + Tcl_Size count) /* If <= 0, "unknown" */ { if (interp) { if (count > 0) { @@ -4670,9 +4673,9 @@ TclMSB( * clzll() = Count of Leading Zeroes in a Long Long * NOTE: we rely on input constraint (n != 0). */ - + return 63 - __builtin_clzll(n); - + #else /* -- cgit v0.12 From 72c2ffce203c148cc673595012dd8cd9d6671312 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 26 May 2025 11:40:28 +0000 Subject: Fix [1dcda0e862]: Build broken (trunk branch) tclCompExpr.c tclOOCall.c. Just by disabling the warning. --- win/tclWinPort.h | 1 + 1 file changed, 1 insertion(+) diff --git a/win/tclWinPort.h b/win/tclWinPort.h index 0f22138..afb76df 100644 --- a/win/tclWinPort.h +++ b/win/tclWinPort.h @@ -461,6 +461,7 @@ typedef DWORD_PTR * PDWORD_PTR; #endif # pragma warning(disable:4267) # pragma warning(disable:4996) +# pragma warning(disable:5287) /* See [1dcda0e862] */ #endif /* -- cgit v0.12 From 7a6af69ba84c0afb4808851f1f657b1461dbec0a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 26 May 2025 11:41:49 +0000 Subject: Update changes.md --- changes.md | 1 + 1 file changed, 1 insertion(+) diff --git a/changes.md b/changes.md index 503725c..c777875 100644 --- a/changes.md +++ b/changes.md @@ -27,6 +27,7 @@ to the userbase. - ["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) # Incompatibilities - No known incompatibilities with the Tcl 9.0.0 public interface. -- cgit v0.12 From 58b76f95b2dea2bc93c90f8a3713e62503a3fcb5 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Mon, 26 May 2025 11:47:06 +0000 Subject: Update changes.md --- changes.md | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/changes.md b/changes.md index c6a3829..8dcdd87 100644 --- a/changes.md +++ b/changes.md @@ -10,6 +10,11 @@ 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. +# Performance + +- [Memory efficient internal representations](https://core.tcl-lang.org/tcl/wiki?name=New+abstract+list+representations) +for list operations on large lists. + # Bug fixes - [tclEpollNotfy PlatformEventsControl panics if websocket disconnected](https://core.tcl-lang.org/tcl/tktview/010d8f38) -- cgit v0.12 From 5c2cca7db27655219083d176c5d2d5a54031ee1b Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Mon, 26 May 2025 11:56:49 +0000 Subject: Update changes for fixed tickets --- changes.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/changes.md b/changes.md index c777875..2523ad7 100644 --- a/changes.md +++ b/changes.md @@ -28,6 +28,8 @@ to the userbase. - [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/7346adc50) + - [Missing include dir for extensions in non-default locations](https://core.tcl-lang.org/tcl/tktview/3335120320) # Incompatibilities - No known incompatibilities with the Tcl 9.0.0 public interface. -- cgit v0.12 From 5303e4fc8c85bd74e142887dbf54701e23cbcd47 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Tue, 27 May 2025 03:23:54 +0000 Subject: Proposed fix for memory leak in TclCompileTryCmd --- generic/tclCompCmdsSZ.c | 17 +++++++++++------ 1 file changed, 11 insertions(+), 6 deletions(-) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index bf66484..baebb1d 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -2864,7 +2864,12 @@ TclCompileTryCmd( handlers = &staticHandler; } - for (; handlerIdx < numHandlers ; handlerIdx++) { + /* 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; @@ -3033,11 +3038,11 @@ TclCompileTryCmd( */ failedToCompile: - while (handlerIdx-- > 0) { - if (handlers[handlerIdx].matchClause) { - TclDecrRefCount(handlers[handlerIdx].matchClause); - } - } + for (handlerIdx = 0; handlerIdx < numHandlers; ++handlerIdx) { + if (handlers[handlerIdx].matchClause) { + TclDecrRefCount(handlers[handlerIdx].matchClause); + } + } if (handlers != &staticHandler) { TclStackFree(interp, handlers); } -- cgit v0.12 From a6a2d6ced9304f67486d4ee9cb39ce672ad604e0 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Tue, 27 May 2025 05:01:08 +0000 Subject: Disable unsupported icu tests for valgrind as dl_load of icu muddies valgrind output --- tests/icu.test | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/tests/icu.test b/tests/icu.test index a86a985..6b26107 100644 --- a/tests/icu.test +++ b/tests/icu.test @@ -7,9 +7,14 @@ if {"::tcltest" ni [namespace children]} { namespace import -force ::tcltest::* } -# Force late loading of ICU if present -catch {::tcl::unsupported::icu} -testConstraint icu [llength [info commands ::tcl::unsupported::icu::detect]] +# Disable ICU tests in the presence of valgrind since the dl_load +# allocations interfere with valgrind output and icu is anyways an +# unsupported component. +if {![testConstraint valgrind]} { + # Force late loading of ICU if present + catch {::tcl::unsupported::icu} + testConstraint icu [llength [info commands ::tcl::unsupported::icu::detect]] +} namespace eval icu { namespace path {::tcl::unsupported ::tcl::mathop} -- cgit v0.12 From deb0e4ee286b66e5f2162efba20cd8e7786ddc7c Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 27 May 2025 11:28:24 +0000 Subject: Add a TCL_UNREACHABLE macro for marking a code path as never reached Inspired by https://en.cppreference.com/w/c/language/attributes/deprecated --- generic/tclBinary.c | 60 ++--- generic/tclClock.c | 12 +- generic/tclCmdAH.c | 5 +- generic/tclCmdIL.c | 4 + generic/tclCmdMZ.c | 12 + generic/tclCompCmdsSZ.c | 2 +- generic/tclConfig.c | 3 +- generic/tclDictObj.c | 24 +- generic/tclDisassemble.c | 10 +- generic/tclEnsemble.c | 9 +- generic/tclEvent.c | 4 +- generic/tclExecute.c | 545 ++++++++++++++++++---------------------------- generic/tclFileName.c | 2 + generic/tclIOCmd.c | 6 +- generic/tclIORChan.c | 2 + generic/tclIcu.c | 4 + generic/tclInt.h | 15 ++ generic/tclInterp.c | 21 +- generic/tclLoad.c | 7 +- generic/tclNamesp.c | 8 +- generic/tclOOBasic.c | 27 +-- generic/tclOODefineCmds.c | 6 +- generic/tclOOInfo.c | 14 +- generic/tclOOProp.c | 6 + generic/tclPkg.c | 22 +- generic/tclProcess.c | 3 +- generic/tclStrIdxTree.c | 8 +- generic/tclStrToD.c | 2 +- generic/tclTimer.c | 2 +- generic/tclTrace.c | 16 +- generic/tclVar.c | 8 +- generic/tclZipfs.c | 2 + generic/tclZlib.c | 35 +-- 33 files changed, 443 insertions(+), 463 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index cce0ca1..e02f47e 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -2502,6 +2502,8 @@ BinaryDecodeHex( case OPT_STRICT: strict = 1; break; + default: + TCL_UNREACHABLE(); } } @@ -2646,6 +2648,8 @@ BinaryEncode64( wrapchar = TclGetStringFromObj(objv[i + 1], &wrapcharlen); } break; + default: + TCL_UNREACHABLE(); } } if (wrapcharlen == 0) { @@ -2770,36 +2774,36 @@ BinaryEncodeUu( case OPT_WRAPCHAR: wrapchar = (const unsigned char *)TclGetStringFromObj( objv[i + 1], &wrapcharlen); - { - const unsigned char *p = wrapchar; - Tcl_Size numBytes = wrapcharlen; - - while (numBytes) { - switch (*p) { - case '\t': - case '\v': - case '\f': - case '\r': - p++; numBytes--; - continue; - case '\n': - numBytes--; - break; - default: - badwrap: - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "invalid wrapchar; will defeat decoding", - -1)); - Tcl_SetErrorCode(interp, "TCL", "BINARY", - "ENCODE", "WRAPCHAR", (char *)NULL); - return TCL_ERROR; - } - } - if (numBytes) { + const unsigned char *p = wrapchar; + Tcl_Size numBytes = wrapcharlen; + + while (numBytes) { + switch (*p) { + case '\t': + case '\v': + case '\f': + case '\r': + p++; + numBytes--; + continue; + case '\n': + numBytes--; + break; + default: goto badwrap; } } + if (numBytes) { + badwrap: + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "invalid wrapchar; will defeat decoding", -1)); + Tcl_SetErrorCode(interp, "TCL", "BINARY", + "ENCODE", "WRAPCHAR", (char *)NULL); + return TCL_ERROR; + } break; + default: + TCL_UNREACHABLE(); } } @@ -2906,6 +2910,8 @@ BinaryDecodeUu( case OPT_STRICT: strict = 1; break; + default: + TCL_UNREACHABLE(); } } @@ -3081,6 +3087,8 @@ BinaryDecode64( case OPT_STRICT: strict = 1; break; + default: + TCL_UNREACHABLE(); } } diff --git a/generic/tclClock.c b/generic/tclClock.c index 4605e58..9f658cd 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -1154,6 +1154,8 @@ ClockConfigureObjCmd( } break; } + default: + TCL_UNREACHABLE(); } } @@ -3159,6 +3161,8 @@ ClockClicksObjCmd( case CLICKS_MICROS: clicks = TclpGetMicroseconds(); break; + default: + TCL_UNREACHABLE(); } Tcl_SetObjResult(interp, Tcl_NewWideIntObj(clicks)); @@ -3371,6 +3375,8 @@ ClockParseFmtScnArgs( } } break; + default: + TCL_UNREACHABLE(); } saw |= 1 << optionIndex; } @@ -3431,8 +3437,8 @@ ClockParseFmtScnArgs( } Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad seconds \"%s\": must be now or integer", - TclGetString(baseObj))); + "bad seconds \"%s\": must be now or integer", + TclGetString(baseObj))); i = baseIdx; goto badOption; } @@ -4537,6 +4543,8 @@ ClockAddObjCmd( case CLC_ADD_SECONDS: yyRelSeconds += offs; break; + default: + TCL_UNREACHABLE(); } if (unitIndex < CLC_ADD_HOURS) { /* date units only */ info->flags |= CLF_RELCONV; diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 6e12a29..1f13529 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -483,6 +483,8 @@ EncodingConvertParseOptions( case FAILINDEX: failVarObj = objv[argIndex]; break; + default: + TCL_UNREACHABLE(); } } /* Get encoding after opts so no need to free it on option error */ @@ -2118,8 +2120,7 @@ PathTypeCmd( TclNewLiteralStringObj(typeName, "volumerelative"); break; default: - /* Should be unreachable */ - return TCL_OK; + TCL_UNREACHABLE(); } Tcl_SetObjResult(interp, typeName); return TCL_OK; diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 76fd7c1..b4d2eb3 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -3504,6 +3504,8 @@ Tcl_LsearchObjCmd( } break; } + default: + TCL_UNREACHABLE(); } } @@ -4684,6 +4686,8 @@ Tcl_LsortObjCmd( group = 1; i++; break; + default: + TCL_UNREACHABLE(); } } if (nocase && (sortInfo.sortMode == SORTMODE_ASCII)) { diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index ca813d7..6ea259b 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -211,6 +211,8 @@ Tcl_RegexpObjCmd( case REGEXP_LAST: i++; goto endOfForLoop; + default: + TCL_UNREACHABLE(); } } @@ -566,6 +568,8 @@ Tcl_RegsubObjCmd( case REGSUB_LAST: idx++; goto endOfForLoop; + default: + TCL_UNREACHABLE(); } } @@ -1580,6 +1584,8 @@ StringIsCmd( } failVarObj = objv[++i]; break; + default: + TCL_UNREACHABLE(); } } } @@ -1877,6 +1883,8 @@ StringIsCmd( case STR_IS_XDIGIT: chcomp = UniCharIsHexDigit; break; + default: + TCL_UNREACHABLE(); } if (chcomp != NULL) { @@ -4186,6 +4194,8 @@ Tcl_TimeRateObjCmd( break; case TMRT_LAST: break; + default: + TCL_UNREACHABLE(); } } @@ -4836,6 +4846,8 @@ TclNRTryObjCmd( haveHandlers = 1; i += 3; break; + default: + TCL_UNREACHABLE(); } } if (bodyShared) { diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 02fcc4d..73f6be1 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -2193,7 +2193,7 @@ IssueSwitchChainedTests( } break; default: - Tcl_Panic("unknown switch mode: %d", mode); + TCL_UNREACHABLE(); } /* diff --git a/generic/tclConfig.c b/generic/tclConfig.c index 689e807..a7b557d 100644 --- a/generic/tclConfig.c +++ b/generic/tclConfig.c @@ -299,8 +299,7 @@ QueryConfigObjCmd( return TCL_OK; default: - Tcl_Panic("QueryConfigObjCmd: Unknown subcommand to 'pkgconfig'. This can't happen"); - break; + TCL_UNREACHABLE(); } return TCL_ERROR; } diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 0d0a9e2..7d7c359 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -3457,20 +3457,18 @@ DictFilterCmd( TclDecrRefCount(resultObj); } return result; - - abnormalResult: - Tcl_DictObjDone(&search); - TclDecrRefCount(keyObj); - TclDecrRefCount(valueObj); - TclDecrRefCount(keyVarObj); - TclDecrRefCount(valueVarObj); - TclDecrRefCount(scriptObj); - TclDecrRefCount(resultObj); - return result; } - Tcl_Panic("unexpected fallthrough"); - /* Control never reaches this point. */ - return TCL_ERROR; + TCL_UNREACHABLE(); + + abnormalResult: + Tcl_DictObjDone(&search); + TclDecrRefCount(keyObj); + TclDecrRefCount(valueObj); + TclDecrRefCount(keyVarObj); + TclDecrRefCount(valueVarObj); + TclDecrRefCount(scriptObj); + TclDecrRefCount(resultObj); + return result; } /* diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index c9b9761..98290d1 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -678,16 +678,16 @@ FormatInstruction( case OPERAND_CLK1: opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++; switch (opnd) { - case 0: + case CLOCK_READ_CLICKS: Tcl_AppendPrintfToObj(bufferObj, "clicks " ); break; - case 1: + case CLOCK_READ_MICROS: Tcl_AppendPrintfToObj(bufferObj, "micros " ); break; - case 2: + case CLOCK_READ_MILLIS: Tcl_AppendPrintfToObj(bufferObj, "millis " ); break; - case 3: + case CLOCK_READ_SECS: Tcl_AppendPrintfToObj(bufferObj, "secs " ); break; default: @@ -1658,7 +1658,7 @@ Tcl_DisassembleObjCmd( codeObjPtr = procPtr->bodyPtr; break; default: - CLANG_ASSERT(0); + TCL_UNREACHABLE(); } /* diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 3d3fbcd..a4d2532 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -230,9 +230,8 @@ TclNamespaceEnsembleCmd( } default: - Tcl_Panic("unexpected ensemble command"); + TCL_UNREACHABLE(); } - return TCL_OK; } /* @@ -387,6 +386,8 @@ InitEnsembleFromOptions( } unknownObj = (len > 0 ? objv[1] : NULL); continue; + default: + TCL_UNREACHABLE(); } } @@ -485,6 +486,8 @@ ReadOneEnsembleOption( Tcl_SetObjResult(interp, resultObj); } break; + default: + TCL_UNREACHABLE(); } return TCL_OK; } @@ -715,6 +718,8 @@ SetEnsembleConfigOptions( } unknownObj = (len > 0 ? objv[1] : NULL); continue; + default: + TCL_UNREACHABLE(); } } diff --git a/generic/tclEvent.c b/generic/tclEvent.c index b3e3dc2..fa71ff6 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -1650,6 +1650,8 @@ Tcl_VwaitObjCmd( vwaitItems[numItems].sourceObj = objv[i]; numItems++; break; + default: + TCL_UNREACHABLE(); } } @@ -1967,7 +1969,7 @@ Tcl_UpdateObjCmd( flags = TCL_IDLE_EVENTS|TCL_DONT_WAIT; break; default: - Tcl_Panic("Tcl_UpdateObjCmd: bad option index to UpdateOptions"); + TCL_UNREACHABLE(); } } else { Tcl_WrongNumArgs(interp, 1, objv, "?idletasks?"); diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 53f894f..504fc8d 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -26,6 +26,12 @@ #include #include +#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 @@ -199,7 +205,7 @@ VarHashFindVar( } while (0) #else #define CHECK_STACK() -#endif +#endif // TCL_COMPILE_DEBUG #define NEXT_INST_F(pcAdjustment, nCleanup, resultHandling) \ do { \ @@ -223,14 +229,14 @@ 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) @@ -245,7 +251,7 @@ VarHashFindVar( case 0: goto cleanup0; \ case 1: goto cleanup1; \ case 2: goto cleanup2; \ - default: Tcl_Panic("should be unreachable"); \ + default: TCL_UNREACHABLE(); \ } \ } while (0) @@ -262,6 +268,7 @@ VarHashFindVar( } else { \ goto cleanupV; \ } \ + TCL_UNREACHABLE(); \ } while (0) #ifndef TCL_COMPILE_DEBUG @@ -272,16 +279,12 @@ VarHashFindVar( switch (*pc) { \ case INST_JUMP_FALSE1: \ NEXT_INST_F0(((condition)? 2 : TclGetInt1AtPtr(pc + 1)), (cleanup)); \ - break; \ case INST_JUMP_TRUE1: \ NEXT_INST_F0(((condition)? TclGetInt1AtPtr(pc + 1) : 2), (cleanup)); \ - break; \ case INST_JUMP_FALSE: \ NEXT_INST_F0(((condition)? 5 : TclGetInt4AtPtr(pc + 1)), (cleanup)); \ - break; \ case INST_JUMP_TRUE: \ NEXT_INST_F0(((condition)? TclGetInt4AtPtr(pc + 1) : 5), (cleanup)); \ - break; \ default: \ if ((condition) < 0) { \ TclNewIntObj(objResultPtr, -1); \ @@ -289,8 +292,8 @@ VarHashFindVar( objResultPtr = TCONST((condition) > 0); \ } \ NEXT_INST_F(0, (cleanup), 1); \ - break; \ } \ + TCL_UNREACHABLE(); \ } while (0) #define JUMP_PEEPHOLE_V(condition, pcAdjustment, cleanup) \ do { \ @@ -298,16 +301,12 @@ VarHashFindVar( switch (*pc) { \ case INST_JUMP_FALSE1: \ NEXT_INST_V(((condition)? 2 : TclGetInt1AtPtr(pc + 1)), (cleanup), 0); \ - break; \ case INST_JUMP_TRUE1: \ NEXT_INST_V(((condition)? TclGetInt1AtPtr(pc + 1) : 2), (cleanup), 0); \ - break; \ case INST_JUMP_FALSE: \ NEXT_INST_V(((condition)? 5 : TclGetInt4AtPtr(pc + 1)), (cleanup), 0); \ - break; \ case INST_JUMP_TRUE: \ NEXT_INST_V(((condition)? TclGetInt4AtPtr(pc + 1) : 5), (cleanup), 0); \ - break; \ default: \ if ((condition) < 0) { \ TclNewIntObj(objResultPtr, -1); \ @@ -315,20 +314,18 @@ VarHashFindVar( objResultPtr = TCONST((condition) > 0); \ } \ NEXT_INST_V(0, (cleanup), 1); \ - break; \ } \ + TCL_UNREACHABLE(); \ } while (0) -#else +#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)); \ - break; \ case INST_JUMP_TRUE: \ NEXT_INST_F0(((condition)? TclGetInt4AtPtr(pc + 1) : 5), (cleanup)); \ - break; \ default: \ if ((condition) < 0) { \ TclNewIntObj(objResultPtr, -1); \ @@ -336,8 +333,8 @@ VarHashFindVar( objResultPtr = TCONST((condition) > 0); \ } \ NEXT_INST_F(0, (cleanup), 1); \ - break; \ } \ + TCL_UNREACHABLE(); \ } while (0) #define JUMP_PEEPHOLE_V(condition, pcAdjustment, cleanup) \ do { \ @@ -345,10 +342,8 @@ VarHashFindVar( switch (*pc) { \ case INST_JUMP_FALSE: \ NEXT_INST_V(((condition)? 5 : TclGetInt4AtPtr(pc + 1)), (cleanup), 0); \ - break; \ case INST_JUMP_TRUE: \ NEXT_INST_V(((condition)? TclGetInt4AtPtr(pc + 1) : 5), (cleanup), 0); \ - break; \ default: \ if ((condition) < 0) { \ TclNewIntObj(objResultPtr, -1); \ @@ -356,11 +351,11 @@ VarHashFindVar( objResultPtr = TCONST((condition) > 0); \ } \ NEXT_INST_V(0, (cleanup), 1); \ - break; \ } \ + TCL_UNREACHABLE(); \ } while (0) -#endif -#else /* TCL_COMPILE_DEBUG */ +#endif // REMOVE_DEPRECATED_OPCODES +#else // TCL_COMPILE_DEBUG #define JUMP_PEEPHOLE_F(condition, pcAdjustment, cleanup) \ do{ \ if ((condition) < 0) { \ @@ -369,6 +364,7 @@ VarHashFindVar( objResultPtr = TCONST((condition) > 0); \ } \ NEXT_INST_F((pcAdjustment), (cleanup), 1); \ + TCL_UNREACHABLE(); \ } while (0) #define JUMP_PEEPHOLE_V(condition, pcAdjustment, cleanup) \ do{ \ @@ -378,8 +374,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 @@ -472,7 +469,7 @@ VarHashFindVar( TRACE_APPEND(("\"%.30s\"\n", O2S(objPtr))) # define TRACE_APPEND_NUM_OBJ(objPtr) \ TRACE_APPEND(("%.30s\n", O2S(objPtr))) -#else /* !TCL_COMPILE_DEBUG */ +#else // !TCL_COMPILE_DEBUG # define TRACE(a) # define TRACE_APPEND(a) # define TRACE_ERROR(interp) @@ -480,7 +477,7 @@ VarHashFindVar( # define O2S(objPtr) # define TRACE_APPEND_OBJ(objPtr) # define TRACE_APPEND_NUM_OBJ(objPtr) -#endif /* TCL_COMPILE_DEBUG */ +#endif // TCL_COMPILE_DEBUG #ifndef REMOVE_DEPRECATED_OPCODES #ifdef PANIC_ON_DEPRECATED_OPCODES @@ -489,7 +486,7 @@ VarHashFindVar( #else #define DEPRECATED_OPCODE_MARK(opcode) /* Do nothing. */ #endif -#endif +#endif // REMOVE_DEPRECATED_OPCODES /* * DTrace instruction probe macros. @@ -565,7 +562,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. @@ -777,11 +774,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); /* @@ -789,11 +782,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); } @@ -944,7 +937,7 @@ TclDeleteExecEnv( { ExecStack *esPtr = eePtr->execStackPtr, *tmpPtr; - cachedInExit = TclInExit(); + cachedInExit = TclInExit(); /* * Delete all stacks in this exec env. @@ -1071,8 +1064,8 @@ GrowEvaluationStack( if (needed <= 0) { return MEMSTART(markerPtr); } - } else { #ifndef PURIFY + } else { Tcl_Obj **tmpMarkerPtr = esPtr->tosPtr + 1; int offset = wordSkip(tmpMarkerPtr); @@ -1089,7 +1082,7 @@ GrowEvaluationStack( *esPtr->markerPtr = (Tcl_Obj *) markerPtr; return memStart; } -#endif +#endif // !PURIFY } /* @@ -1238,10 +1231,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; @@ -1253,10 +1242,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?", @@ -1292,7 +1281,7 @@ TclStackFree( #ifdef PURIFY eePtr->execStackPtr->nextPtr = NULL; DeleteExecStack(esPtr); -#endif +#endif // PURIFY } else { eePtr->execStackPtr = esPtr; } @@ -1304,12 +1293,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); } @@ -1320,24 +1308,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); } @@ -1430,12 +1414,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); @@ -1718,19 +1700,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) { @@ -1826,7 +1803,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"); @@ -1867,11 +1843,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. @@ -1885,7 +1859,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; @@ -1958,7 +1932,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 *); @@ -1978,7 +1951,7 @@ 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; @@ -2047,9 +2020,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 @@ -2121,7 +2094,7 @@ TEBCresume( Tcl_Obj **objv = NULL; Tcl_Size length, objc = 0, varIdx, numArgs; unsigned tblIdx; - int pcAdjustment, encIndex; + int pcAdjustment; Var *varPtr, *arrayPtr; #ifdef TCL_COMPILE_DEBUG char cmdNameBuf[21]; @@ -2642,41 +2615,34 @@ TEBCresume( objResultPtr = codePtr->objArrayPtr[TclGetUInt1AtPtr(pc + 1)]; TRACE_WITH_OBJ(("%u => ", TclGetUInt1AtPtr(pc + 1)), objResultPtr); NEXT_INST_F(2, 0, 1); - break; #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_F0(1, 0); - break; case INST_DUP: objResultPtr = OBJ_AT_TOS; TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(1, 0, 1); - break; case INST_OVER: 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; - numArgs = TclGetUInt4AtPtr(pc + 1); - a = tosPtr - (numArgs - 1); - b = tosPtr; + Tcl_Obj **a = tosPtr - (numArgs - 1); + Tcl_Obj **b = tosPtr; while (a < b) { tmpPtr = *a; *a = *b; @@ -2687,34 +2653,26 @@ TEBCresume( TRACE(("%u => OK\n", (unsigned) numArgs)); NEXT_INST_F0(5, 0); } - break; - case INST_SWAP: { - Tcl_Obj *a, *b; - - a = OBJ_AT_TOS; - b = OBJ_UNDER_TOS; - OBJ_UNDER_TOS = a; - OBJ_AT_TOS = b; + 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); - } - break; case INST_STR_CONCAT1: numArgs = TclGetUInt1AtPtr(pc + 1); DECACHE_STACK_INFO(); 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 => ", (unsigned)numArgs), objResultPtr); NEXT_INST_V(2, numArgs, 1); - break; case INST_CONCAT_STK: /* @@ -2726,7 +2684,6 @@ TEBCresume( objResultPtr = Tcl_ConcatObj(numArgs, &OBJ_AT_DEPTH(numArgs - 1)); TRACE_WITH_OBJ(("%u => ", (unsigned) numArgs), objResultPtr); NEXT_INST_V(5, numArgs, 1); - break; case INST_EXPAND_START: /* @@ -2748,7 +2705,6 @@ TEBCresume( PUSH_TAUX_OBJ(objPtr); TRACE(("=> mark depth as %" SIZEd "\n", CURR_DEPTH)); NEXT_INST_F0(1, 0); - break; case INST_EXPAND_DROP: /* @@ -2767,11 +2723,7 @@ TEBCresume( 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 @@ -2795,13 +2747,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) { /* @@ -2822,23 +2774,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_F0(5, 0); - } - break; 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++; @@ -2878,7 +2829,6 @@ TEBCresume( TclNewObj(objResultPtr); NEXT_INST_F(1, 0, 1); - break; case INST_INVOKE_STK: objc = TclGetUInt4AtPtr(pc + 1); @@ -2899,8 +2849,6 @@ TEBCresume( #ifdef TCL_COMPILE_DEBUG if (tclTraceExec >= TCL_TRACE_BYTECODE_EXEC_COMMANDS) { - Tcl_Size i; - if (traceInstructions) { strncpy(cmdNameBuf, TclGetString(objv[0]), 20); TRACE(("%" SIZEd " => call ", objc)); @@ -2908,6 +2856,7 @@ TEBCresume( fprintf(stdout, "%" SIZEd ": (%" SIZEd ") invoking ", iPtr->numLevels, PC_REL); } + Tcl_Size i; for (i = 0; i < objc; i++) { TclPrintObject(stdout, objv[i], 15); fprintf(stdout, " "); @@ -2939,7 +2888,7 @@ 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: @@ -2950,8 +2899,6 @@ TEBCresume( cleanup = objc; #ifdef TCL_COMPILE_DEBUG if (tclTraceExec >= TCL_TRACE_BYTECODE_EXEC_COMMANDS) { - Tcl_Size i; - if (traceInstructions) { strncpy(cmdNameBuf, TclGetString(objv[0]), 20); TRACE(("%" SIZEd " => call (implementation %s) ", objc, O2S(objPtr))); @@ -2960,6 +2907,7 @@ TEBCresume( "%" SIZEd ": (%" SIZEd ") invoking (using implementation %s) ", iPtr->numLevels, PC_REL, O2S(objPtr)); } + Tcl_Size i; for (i = 0; i < objc; i++) { if (i < numArgs) { fprintf(stdout, "<"); @@ -3664,6 +3612,7 @@ TEBCresume( goto doIncrArray; default: Tcl_Panic("unknown instruction"); + TCL_UNREACHABLE(); } case INST_INCR_ARRAY_STK_IMM: @@ -4111,7 +4060,6 @@ TEBCresume( TRACE_ERROR(interp); goto gotError; } - break; /* * End of INST_UNSET instructions. @@ -4162,11 +4110,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, varIdx); + Tcl_Obj *resPtr = TclPtrSetVarIdx(interp, varPtr, arrayPtr, + part1Ptr, NULL, objPtr, TCL_LEAVE_ERR_MSG, varIdx); CACHE_STACK_INFO(); if (resPtr == NULL) { TRACE_ERROR(interp); @@ -4179,7 +4125,9 @@ TEBCresume( constError: 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; } @@ -4400,7 +4348,6 @@ TEBCresume( TRACE_APPEND(("link made\n")); NEXT_INST_F0(5, 1); } - break; /* * End of variable linking instructions. @@ -4491,19 +4438,19 @@ TEBCresume( #endif 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. Lookup by string. */ - + + case INST_JUMP_TABLE: tblIdx = TclGetInt4AtPtr(pc + 1); - jtPtr = (JumptableInfo *) codePtr->auxDataArrayPtr[tblIdx].clientData; + JumptableInfo *jtPtr = (JumptableInfo *) + codePtr->auxDataArrayPtr[tblIdx].clientData; TRACE(("%u \"%.20s\" => ", tblIdx, O2S(OBJ_AT_TOS))); hPtr = Tcl_FindHashEntry(&jtPtr->hashTable, TclGetString(OBJ_AT_TOS)); if (hPtr != NULL) { @@ -4516,21 +4463,18 @@ TEBCresume( TRACE_APPEND(("not found in table\n")); NEXT_INST_F0(5, 1); } - } - break; - case INST_JUMP_TABLE_NUM: { - Tcl_HashEntry *hPtr; - JumptableNumInfo *jtnPtr; - Tcl_WideInt key; /* * Jump to location looked up in a hashtable; fall through to next * instr if lookup fails. Lookup by integer. */ + case INST_JUMP_TABLE_NUM: tblIdx = TclGetInt4AtPtr(pc + 1); - jtnPtr = (JumptableNumInfo *) codePtr->auxDataArrayPtr[tblIdx].clientData; + JumptableNumInfo *jtnPtr = (JumptableNumInfo *) + codePtr->auxDataArrayPtr[tblIdx].clientData; TRACE(("%u \"%.20s\" => ", tblIdx, O2S(OBJ_AT_TOS))); + Tcl_WideInt key; if (Tcl_GetWideIntFromObj(NULL, OBJ_AT_TOS, &key) != TCL_OK) { goto jumpTableNumFallthrough; } @@ -4547,7 +4491,6 @@ TEBCresume( NEXT_INST_F0(5, 1); } } - break; /* * ----------------------------------------------------------------- @@ -4558,7 +4501,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; @@ -4570,12 +4512,10 @@ 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: { Tcl_WideInt level; CallFrame *framePtr = iPtr->varFramePtr; @@ -4948,7 +4888,7 @@ TEBCresume( */ { - int nocase, match, cflags, fromIdxEnc, toIdxEnc; + int nocase, match, fromIdxEnc, toIdxEnc; Tcl_Size slength, length2, fromIdx, toIdx, index, s1len, s2len, numIndices; const char *s1, *s2; @@ -5011,15 +4951,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) { @@ -5049,7 +4987,7 @@ TEBCresume( 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 */ /* @@ -5057,7 +4995,7 @@ TEBCresume( */ valuePtr = OBJ_AT_TOS; - encIndex = TclGetInt4AtPtr(pc + 1); + int encIndex = TclGetInt4AtPtr(pc + 1); TRACE(("\"%.30s\" %d => ", O2S(valuePtr), encIndex)); /* @@ -5075,12 +5013,12 @@ TEBCresume( 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); } @@ -5110,6 +5048,7 @@ TEBCresume( lindexFastPath2: TRACE_APPEND_OBJ(objResultPtr); NEXT_INST_F(pcAdjustment, 1, 1); + } case INST_LIST_INDEX_MULTI: /* 'lindex' with multiple index args */ /* @@ -5170,8 +5109,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; } @@ -5179,7 +5118,6 @@ TEBCresume( /* * Set result. */ - CACHE_STACK_INFO(); TRACE_APPEND_OBJ(objResultPtr); NEXT_INST_V(5, numIndices + 1, -1); @@ -5298,13 +5236,12 @@ TEBCresume( } else { objResultPtr = TclListObjRange(interp, valuePtr, fromIdx, toIdx); } + CACHE_STACK_INFO(); if (objResultPtr == NULL) { - CACHE_STACK_INFO(); TRACE_ERROR(interp); goto gotError; } - CACHE_STACK_INFO(); TRACE_APPEND_OBJ(objResultPtr); NEXT_INST_F(9, 1, 1); @@ -5330,7 +5267,6 @@ TEBCresume( match = 0; if (length > 0) { Tcl_Size i = 0; - Tcl_Obj *o; int isAbstractList = TclObjTypeHasProc(value2Ptr, indexProc) != NULL; /* @@ -5338,14 +5274,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); } @@ -5405,32 +5342,27 @@ TEBCresume( } case INST_LREPLACE: { - size_t numToDelete, numNewElems; - int end_indicator; - int haveSecondIndex, flags; - Tcl_Obj *fromIdxObj, *toIdxObj; numArgs = TclGetUInt4AtPtr(pc + 1); - flags = TclGetInt1AtPtr(pc + 5); + int flags = TclGetInt1AtPtr(pc + 5); /* Stack: ... listobj index1 ?index2? new1 ... newN */ valuePtr = OBJ_AT_DEPTH(numArgs - 1); /* haveSecondIndex==0 => pure insert */ - haveSecondIndex = (flags & TCL_LREPLACE4_SINGLE_INDEX) == 0; - numNewElems = numArgs - 2 - haveSecondIndex; + int haveSecondIndex = (flags & TCL_LREPLACE4_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(numArgs - 2); - toIdxObj = haveSecondIndex ? OBJ_AT_DEPTH(numArgs - 3) : NULL; + int endIndicator = (flags & TCL_LREPLACE4_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); @@ -5441,9 +5373,9 @@ TEBCresume( } 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); @@ -5480,7 +5412,7 @@ TEBCresume( TRACE_APPEND_OBJ(valuePtr); NEXT_INST_V(6, numArgs - 1, 0); } - } + } /* * End of INST_LIST and related instructions. @@ -5554,57 +5486,34 @@ TEBCresume( 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(("\"%.30s\" => ", 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_OBJ(objResultPtr); - NEXT_INST_F(1, 1, 1); - } else { - slength = Tcl_UtfToUpper(TclGetString(valuePtr)); - Tcl_SetObjLength(valuePtr, slength); - TclFreeInternalRep(valuePtr); - TRACE_APPEND_OBJ(valuePtr); - NEXT_INST_F0(1, 0); - } + transform = Tcl_UtfToUpper; + goto applyStringTransform; case INST_STR_LOWER: - valuePtr = OBJ_AT_TOS; - TRACE(("\"%.30s\" => ", 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_OBJ(objResultPtr); - NEXT_INST_F(1, 1, 1); - } else { - slength = Tcl_UtfToLower(TclGetString(valuePtr)); - Tcl_SetObjLength(valuePtr, slength); - TclFreeInternalRep(valuePtr); - TRACE_APPEND_OBJ(valuePtr); - NEXT_INST_F0(1, 0); - } + transform = Tcl_UtfToLower; + goto applyStringTransform; case INST_STR_TITLE: + transform = Tcl_UtfToTitle; + applyStringTransform: valuePtr = OBJ_AT_TOS; TRACE(("\"%.30s\" => ", O2S(valuePtr))); if (Tcl_IsShared(valuePtr)) { - s1 = TclGetStringFromObj(valuePtr, &slength); - TclNewStringObj(objResultPtr, s1, slength); - slength = Tcl_UtfToTitle(TclGetString(objResultPtr)); + objResultPtr = Tcl_DuplicateObj(valuePtr); + slength = transform(TclGetString(objResultPtr)); Tcl_SetObjLength(objResultPtr, slength); 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_OBJ(valuePtr); NEXT_INST_F0(1, 0); } + } case INST_STR_INDEX: value2Ptr = OBJ_AT_TOS; @@ -5616,13 +5525,15 @@ TEBCresume( */ 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); @@ -5658,12 +5569,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; @@ -5847,10 +5754,9 @@ TEBCresume( ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &slength); match = 1; if (slength > 0) { - int ch; end = ustring1 + slength; for (p=ustring1 ; p ", O2S(valuePtr), O2S(value2Ptr))); @@ -5973,37 +5875,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); } - break; + } 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); } - break; /* * End of string-related instructions. @@ -6187,7 +6086,6 @@ TEBCresume( (Tcl_WideUInt)w2*(Tcl_WideUInt)wResult); goto wideResultOfArithmetic; } - break; case INST_RSHIFT: if (w2 < 0) { @@ -6236,7 +6134,6 @@ TEBCresume( wResult = w1 >> ((int) w2); goto wideResultOfArithmetic; } - break; case INST_LSHIFT: if (w2 < 0) { @@ -6426,7 +6323,6 @@ TEBCresume( TclSetIntObj(valuePtr, wResult); TRACE(("%s\n", O2S(valuePtr))); NEXT_INST_F0(1, 1); - break; case INST_DIV: if (w2 == 0) { @@ -6496,12 +6392,11 @@ TEBCresume( } 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"))); @@ -6569,7 +6464,6 @@ TEBCresume( /* -NaN => NaN */ TRACE_APPEND_NUM_OBJ(valuePtr); NEXT_INST_F0(1, 0); - break; case TCL_NUMBER_INT: w1 = *((const Tcl_WideInt *) ptr1); if (w1 != WIDE_MIN) { @@ -6678,7 +6572,6 @@ TEBCresume( TRACE_APPEND(("numeric, same Tcl_Obj\n")); NEXT_INST_F0(1, 0); } - break; /* * End of numeric operator instructions. @@ -6695,7 +6588,6 @@ TEBCresume( } TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(valuePtr)), objResultPtr); NEXT_INST_F(1, 0, 1); - break; case INST_BREAK: /* @@ -6943,7 +6835,6 @@ TEBCresume( Tcl_ListObjAppendElement(NULL, objPtr, OBJ_AT_TOS); NEXT_INST_F0(1, 1); } - break; case INST_BEGIN_CATCH: /* @@ -6957,7 +6848,6 @@ TEBCresume( TclGetUInt4AtPtr(pc + 1), (Tcl_Size)(catchTop - initCatchTop - 1), CURR_DEPTH)); NEXT_INST_F0(5, 0); - break; case INST_END_CATCH: catchTop--; @@ -6967,7 +6857,6 @@ TEBCresume( result = TCL_OK; TRACE(("=> catchTop=%" SIZEd "\n", (Tcl_Size)(catchTop - initCatchTop - 1))); NEXT_INST_F0(1, 0); - break; case INST_PUSH_RESULT: objResultPtr = Tcl_GetObjResult(interp); @@ -6981,13 +6870,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(); @@ -6995,7 +6882,6 @@ TEBCresume( CACHE_STACK_INFO(); TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(1, 0, 1); - break; #ifndef REMOVE_DEPRECATED_OPCODES case INST_RETURN_CODE_BRANCH: { @@ -7057,7 +6943,6 @@ TEBCresume( TRACE_APPEND(("%d\n", match ? 1 : 0)); JUMP_PEEPHOLE_F(match ? 1 : 0, 5, 2); } - break; /* * ----------------------------------------------------------------- @@ -7084,7 +6969,6 @@ TEBCresume( TRACE_APPEND(("OK\n")); NEXT_INST_F0(1, 1); } - break; case INST_DICT_EXISTS: { int found; @@ -7286,8 +7170,8 @@ TEBCresume( &OBJ_AT_DEPTH(numArgs - 1)); break; default: - cleanup = 0; /* stop compiler warning */ Tcl_Panic("Should not happen!"); + TCL_UNREACHABLE(); } if (result != TCL_OK) { @@ -7398,7 +7282,6 @@ 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, @@ -7430,6 +7313,7 @@ TEBCresume( break; default: Tcl_Panic("Should not happen!"); + TCL_UNREACHABLE(); } if (TclIsVarDirectWritable(varPtr)) { @@ -7491,6 +7375,7 @@ TEBCresume( if (varPtr->value.objPtr) { if (TclHasInternalRep(varPtr->value.objPtr, &dictIteratorType)) { Tcl_Panic("mis-issued dictFirst!"); + TCL_UNREACHABLE(); } TclDecrRefCount(varPtr->value.objPtr); } @@ -7511,6 +7396,7 @@ TEBCresume( Tcl_DictObjNext(searchPtr, &keyPtr, &valuePtr, &done); } else { Tcl_Panic("mis-issued dictNext!"); + TCL_UNREACHABLE(); } } pushDictIteratorResult: @@ -7563,6 +7449,7 @@ TEBCresume( } if (length != duiPtr->length) { Tcl_Panic("dictUpdateStart argument length mismatch"); + TCL_UNREACHABLE(); } for (i=0 ; i "), objResultPtr); NEXT_INST_F(2, 0, 1); } - break; default: Tcl_Panic("TclNRExecuteByteCode: unrecognized opCode %u", *pc); @@ -8087,44 +7972,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; - unsigned offset; - - 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); - offset = TclGetUInt4AtPtr(pc + 1); - pc += (offset - 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 @@ -8462,8 +8340,7 @@ ExecuteExtendedBinaryMathOp( mp_clear(&big2); break; default: - /* Unused, here to silence compiler warning */ - invalid = 0; + TCL_UNREACHABLE(); } if (invalid) { Tcl_SetObjResult(interp, Tcl_NewStringObj( @@ -8540,8 +8417,7 @@ ExecuteExtendedBinaryMathOp( mp_clear(&big1); break; default: - /* Unused, here to silence compiler warning. */ - zero = 0; + TCL_UNREACHABLE(); } if (zero) { return constants[0]; @@ -8630,8 +8506,7 @@ ExecuteExtendedBinaryMathOp( wResult = w1 ^ w2; break; default: - /* Unused, here to silence compiler warning. */ - wResult = 0; + TCL_UNREACHABLE(); } WIDE_RESULT(wResult); @@ -8879,8 +8754,7 @@ ExecuteExtendedBinaryMathOp( dResult = d1 / d2; break; default: - /* Unused, here to silence compiler warning. */ - dResult = 0; + TCL_UNREACHABLE(); } doubleResult: @@ -8968,11 +8842,7 @@ ExecuteExtendedBinaryMathOp( break; default: - /* - * Unused, here to silence compiler warning. - */ - - wResult = 0; + TCL_UNREACHABLE(); } WIDE_RESULT(wResult); @@ -9023,10 +8893,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 * @@ -9081,10 +8951,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 @@ -9174,6 +9044,8 @@ TclCompareTwoNumbers( } mp_clear(&big2); return compare; + default: + TCL_UNREACHABLE(); } break; @@ -9221,6 +9093,8 @@ TclCompareTwoNumbers( } Tcl_InitBignumFromDouble(NULL, d1, &big1); goto bigCompare; + default: + TCL_UNREACHABLE(); } break; @@ -9258,10 +9132,13 @@ TclCompareTwoNumbers( mp_clear(&big1); mp_clear(&big2); return compare; + default: + TCL_UNREACHABLE(); } break; default: Tcl_Panic("unexpected number type"); + TCL_UNREACHABLE(); } return TCL_ERROR; } diff --git a/generic/tclFileName.c b/generic/tclFileName.c index 068a041..693018b 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -1233,6 +1233,8 @@ Tcl_GlobObjCmd( case GLOB_LAST: /* -- */ i++; goto endOfForLoop; + default: + TCL_UNREACHABLE(); } } diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index 3e8b39a..8735627 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -1605,7 +1605,7 @@ Tcl_SocketObjCmd( } break; default: - Tcl_Panic("Tcl_SocketObjCmd: bad option index to SocketOptions"); + TCL_UNREACHABLE(); } } if (server) { @@ -1810,6 +1810,8 @@ Tcl_FcopyObjCmd( case FcopyCommand: cmdPtr = objv[i+1]; break; + default: + TCL_UNREACHABLE(); } } @@ -1876,6 +1878,8 @@ ChanPendingObjCmd( Tcl_SetObjResult(interp, Tcl_NewWideIntObj(Tcl_OutputBuffered(chan))); } break; + default: + TCL_UNREACHABLE(); } return TCL_OK; } diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c index e891933..6b981a1 100644 --- a/generic/tclIORChan.c +++ b/generic/tclIORChan.c @@ -2109,6 +2109,8 @@ EncodeEventMask( case EVENT_WRITE: events |= TCL_WRITABLE; break; + default: + TCL_UNREACHABLE(); } listc --; } diff --git a/generic/tclIcu.c b/generic/tclIcu.c index 51334dc..d2d0f09 100644 --- a/generic/tclIcu.c +++ b/generic/tclIcu.c @@ -1000,6 +1000,8 @@ static int IcuParseConvertOptions( Tcl_SetObjResult(interp, Tcl_NewStringObj( "Option -failindex not implemented.", TCL_INDEX_NONE)); return TCL_ERROR; + default: + TCL_UNREACHABLE(); } } *strictPtr = strict; @@ -1169,6 +1171,8 @@ IcuNormalizeObjCmd( return TCL_ERROR; } break; + default: + TCL_UNREACHABLE(); } } diff --git a/generic/tclInt.h b/generic/tclInt.h index dc915e5..c50462f 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -141,6 +141,21 @@ # define Tcl_ConditionFinalize(condPtr) #endif +// A way to mark a code path as unreachable. +#ifndef TCL_UNREACHABLE +#if defined(__STDC__) && __STDC__ >= 202311L +#include +#define TCL_UNREACHABLE() unreachable() +#elif defined(__GNUC__) +#define TCL_UNREACHABLE() __builtin_unreachable() +#elif defined(_MSC_VER) +#include +#define TCL_UNREACHABLE() __assume(false) +#else +#define TCL_UNREACHABLE() ((void) 0) +#endif +#endif // TCL_UNREACHABLE + /* * The following procedures allow namespaces to be customized to support * special name resolution rules for commands/variables. diff --git a/generic/tclInterp.c b/generic/tclInterp.c index c873401..024ae7a 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -756,6 +756,8 @@ NRInterpCmd( case OPT_LAST: i++; goto endOfForLoop; + default: + TCL_UNREACHABLE(); } } @@ -1022,8 +1024,7 @@ NRInterpCmd( case LIMIT_TYPE_TIME: return ChildTimeLimitCmd(interp, childInterp, 4, objc, objv); default: - Tcl_Panic("unreachable"); - return TCL_ERROR; + TCL_UNREACHABLE(); } } case OPT_MARKTRUSTED: @@ -1147,8 +1148,7 @@ NRInterpCmd( return TCL_OK; } default: - Tcl_Panic("unreachable"); - return TCL_ERROR; + TCL_UNREACHABLE(); } } @@ -2677,9 +2677,10 @@ NRChildCmd( return ChildCommandLimitCmd(interp, childInterp, 3, objc,objv); case LIMIT_TYPE_TIME: return ChildTimeLimitCmd(interp, childInterp, 3, objc, objv); + default: + TCL_UNREACHABLE(); } } - break; case OPT_MARKTRUSTED: if (objc != 2) { Tcl_WrongNumArgs(interp, 2, objv, NULL); @@ -2692,6 +2693,8 @@ NRChildCmd( return TCL_ERROR; } return ChildRecursionLimit(interp, childInterp, objc - 2, objv + 2); + default: + TCL_UNREACHABLE(); } return TCL_ERROR; @@ -4529,6 +4532,8 @@ ChildCommandLimitCmd( Tcl_NewWideIntObj(Tcl_LimitGetCommands(childInterp))); } break; + default: + TCL_UNREACHABLE(); } return TCL_OK; } else if ((objc-consumedObjc) & 1 /* isOdd(objc-consumedObjc) */) { @@ -4579,6 +4584,8 @@ ChildCommandLimitCmd( return TCL_ERROR; } break; + default: + TCL_UNREACHABLE(); } } if (scriptObj != NULL) { @@ -4729,6 +4736,8 @@ ChildTimeLimitCmd( Tcl_SetObjResult(interp, Tcl_NewWideIntObj(limitMoment.sec)); } break; + default: + TCL_UNREACHABLE(); } return TCL_OK; } else if ((objc-consumedObjc) & 1 /* isOdd(objc-consumedObjc) */) { @@ -4802,6 +4811,8 @@ ChildTimeLimitCmd( } limitMoment.sec = (long long) tmp; break; + default: + TCL_UNREACHABLE(); } } if (milliObj != NULL || secObj != NULL) { diff --git a/generic/tclLoad.c b/generic/tclLoad.c index f69db4e..0272e02 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -157,13 +157,14 @@ Tcl_LoadObjCmd( &index) != TCL_OK) { return TCL_ERROR; } - ++objv; --objc; + ++objv; + --objc; if (LOAD_GLOBAL == index) { flags |= TCL_LOAD_GLOBAL; } else if (LOAD_LAZY == index) { flags |= TCL_LOAD_LAZY; } else { - break; + break; } } if ((objc < 2) || (objc > 4)) { @@ -599,6 +600,8 @@ Tcl_UnloadObjCmd( case UNLOAD_LAST: /* -- */ i++; goto endOfForLoop; + default: + TCL_UNREACHABLE(); } } endOfForLoop: diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 6d8ecb4..0d5776e 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -4769,15 +4769,14 @@ NamespaceWhichCmd( TclNewObj(resultPtr); switch (lookupType) { - case 0: { /* -command */ + case 0: /* -command */ Tcl_Command cmd = Tcl_GetCommandFromObj(interp, objv[objc-1]); if (cmd != NULL) { Tcl_GetCommandFullName(interp, cmd, resultPtr); } break; - } - case 1: { /* -variable */ + case 1: /* -variable */ Tcl_Var var = Tcl_FindNamespaceVar(interp, TclGetString(objv[objc-1]), NULL, /*flags*/ 0); @@ -4785,7 +4784,8 @@ NamespaceWhichCmd( Tcl_GetVariableFullName(interp, var, resultPtr); } break; - } + default: + TCL_UNREACHABLE(); } Tcl_SetObjResult(interp, resultPtr); return TCL_OK; diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index 36b9e9c..f7bb969 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -1207,13 +1207,7 @@ TclOOSelfObjCmd( } else if (mPtr->declaringObjectPtr != NULL) { declarerPtr = mPtr->declaringObjectPtr; } else { - /* - * This should be unreachable code. - */ - - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "method without declarer!", TCL_AUTO_LENGTH)); - return TCL_ERROR; + TCL_UNREACHABLE(); } result[0] = TclOOObjectName(interp, declarerPtr); @@ -1239,13 +1233,7 @@ TclOOSelfObjCmd( } else if (mPtr->declaringObjectPtr != NULL) { declarerPtr = mPtr->declaringObjectPtr; } else { - /* - * This should be unreachable code. - */ - - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "method without declarer!", TCL_AUTO_LENGTH)); - return TCL_ERROR; + TCL_UNREACHABLE(); } result[0] = TclOOObjectName(interp, declarerPtr); @@ -1284,13 +1272,7 @@ TclOOSelfObjCmd( } else if (mPtr->declaringObjectPtr != NULL) { declarerPtr = mPtr->declaringObjectPtr; } else { - /* - * This should be unreachable code. - */ - - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "method without declarer!", TCL_AUTO_LENGTH)); - return TCL_ERROR; + TCL_UNREACHABLE(); } result[0] = TclOOObjectName(interp, declarerPtr); result[1] = mPtr->namePtr; @@ -1302,8 +1284,9 @@ TclOOSelfObjCmd( TclNewIndexObj(result[1], contextPtr->index); Tcl_SetObjResult(interp, Tcl_NewListObj(2, result)); return TCL_OK; + default: + TCL_UNREACHABLE(); } - return TCL_ERROR; } /* diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index 4c6957c..edccec3 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -1738,9 +1738,9 @@ TclOODefineDefnNsObjCmd( * Update the correct field of the class definition. */ - if (kind) { + if (kind) { // -instance storagePtr = &clsPtr->objDefinitionNs; - } else { + } else { // -class storagePtr = &clsPtr->clsDefinitionNs; } if (*storagePtr != NULL) { @@ -2097,6 +2097,8 @@ TclOODefineMethodObjCmd( case MODE_UNEXPORT: isPublic = 0; break; + default: + TCL_UNREACHABLE(); } } else { if (IsPrivateDefine(interp)) { diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c index 363dab2..c1cbb08 100644 --- a/generic/tclOOInfo.c +++ b/generic/tclOOInfo.c @@ -488,6 +488,8 @@ InfoObjectIsACmd( return TCL_ERROR; } break; + default: + TCL_UNREACHABLE(); } /* @@ -541,6 +543,8 @@ InfoObjectIsACmd( result = TclOOIsReachable(o2Ptr->classPtr, oPtr->selfCls); } break; + default: + TCL_UNREACHABLE(); } Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result)); return TCL_OK; @@ -631,6 +635,8 @@ InfoObjectMethodsCmd( return TCL_ERROR; } break; + default: + TCL_UNREACHABLE(); } } } @@ -1120,9 +1126,9 @@ InfoClassDefnNsCmd( return TCL_ERROR; } - if (kind) { + if (kind) { // -instance nsNamePtr = clsPtr->objDefinitionNs; - } else { + } else { // -class nsNamePtr = clsPtr->clsDefinitionNs; } if (nsNamePtr) { @@ -1387,6 +1393,8 @@ InfoClassMethodsCmd( return TCL_ERROR; } break; + default: + TCL_UNREACHABLE(); } } } @@ -1402,6 +1410,8 @@ InfoClassMethodsCmd( case SCOPE_UNEXPORTED: flag = 0; break; + default: + TCL_UNREACHABLE(); } } diff --git a/generic/tclOOProp.c b/generic/tclOOProp.c index bf40c2f..1ef7dd8 100644 --- a/generic/tclOOProp.c +++ b/generic/tclOOProp.c @@ -1099,6 +1099,8 @@ TclOODefinePropertyCmd( return TCL_ERROR; } break; + default: + TCL_UNREACHABLE(); } } @@ -1221,6 +1223,8 @@ TclOOInfoClassPropCmd( case PROP_WRITABLE: writable = 1; break; + default: + TCL_UNREACHABLE(); } } @@ -1279,6 +1283,8 @@ TclOOInfoObjectPropCmd( case PROP_WRITABLE: writable = 1; break; + default: + TCL_UNREACHABLE(); } } diff --git a/generic/tclPkg.c b/generic/tclPkg.c index e30a457..cfefc3e 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -1099,13 +1099,12 @@ TclNRPackageObjCmd( } switch (optionIndex) { case PKG_FILES: { - PkgFiles *pkgFiles; - if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "package"); return TCL_ERROR; } - pkgFiles = (PkgFiles *) Tcl_GetAssocData(interp, "tclPkgFiles", NULL); + PkgFiles *pkgFiles = (PkgFiles *) + Tcl_GetAssocData(interp, "tclPkgFiles", NULL); if (pkgFiles) { Tcl_HashEntry *entry = Tcl_FindHashEntry(&pkgFiles->table, TclGetString(objv[2])); @@ -1117,12 +1116,11 @@ TclNRPackageObjCmd( break; } case PKG_FORGET: { - const char *keyString; PkgFiles *pkgFiles = (PkgFiles *) Tcl_GetAssocData(interp, "tclPkgFiles", NULL); for (i = 2; i < objc; i++) { - keyString = TclGetString(objv[i]); + const char *keyString = TclGetString(objv[i]); if (pkgFiles) { hPtr = Tcl_FindHashEntry(&pkgFiles->table, keyString); if (hPtr) { @@ -1158,8 +1156,7 @@ TclNRPackageObjCmd( } case PKG_IFNEEDED: { Tcl_Size length; - int res; - char *argv3i, *avi; + char *argv3i; if ((objc != 4) && (objc != 5)) { Tcl_WrongNumArgs(interp, 2, objv, "package version ?script?"); @@ -1184,13 +1181,14 @@ TclNRPackageObjCmd( for (availPtr = pkgPtr->availPtr, prevPtr = NULL; availPtr != NULL; prevPtr = availPtr, availPtr = availPtr->nextPtr) { + char *avi; if (CheckVersionAndConvert(interp, availPtr->version, &avi, NULL) != TCL_OK) { Tcl_Free(argv3i); return TCL_ERROR; } - res = CompareVersions(avi, argv3i, NULL); + int res = CompareVersions(avi, argv3i, NULL); Tcl_Free(avi); if (res == 0) { @@ -1395,9 +1393,7 @@ TclNRPackageObjCmd( return TCL_OK; } break; - case PKG_UNKNOWN: { - Tcl_Size length; - + case PKG_UNKNOWN: if (objc == 2) { if (iPtr->packageUnknown != NULL) { Tcl_SetObjResult(interp, @@ -1407,6 +1403,7 @@ TclNRPackageObjCmd( if (iPtr->packageUnknown != NULL) { Tcl_Free(iPtr->packageUnknown); } + Tcl_Size length; argv2 = TclGetStringFromObj(objv[2], &length); if (argv2[0] == 0) { iPtr->packageUnknown = NULL; @@ -1418,7 +1415,6 @@ TclNRPackageObjCmd( return TCL_ERROR; } break; - } case PKG_PREFER: { static const char *const pkgPreferOptions[] = { "latest", "stable", NULL @@ -1529,7 +1525,7 @@ TclNRPackageObjCmd( break; } default: - Tcl_Panic("Tcl_PackageObjCmd: bad option index to pkgOptions"); + TCL_UNREACHABLE(); } return TCL_OK; } diff --git a/generic/tclProcess.c b/generic/tclProcess.c index f529212..9f4b849 100644 --- a/generic/tclProcess.c +++ b/generic/tclProcess.c @@ -499,7 +499,8 @@ ProcessStatusObjCmd( &index) != TCL_OK) { return TCL_ERROR; } - ++objv; --objc; + ++objv; + --objc; if (STATUS_WAIT == index) { options = 0; } else { diff --git a/generic/tclStrIdxTree.c b/generic/tclStrIdxTree.c index 07accc2..c6cf5ff 100644 --- a/generic/tclStrIdxTree.c +++ b/generic/tclStrIdxTree.c @@ -524,12 +524,12 @@ TclStrIdxTreeTestObjCmd( case O_INDEX: case O_PUTS_INDEX: { - Tcl_Obj **lstv; - Tcl_Size i, lstc; TclStrIdxTree idxTree = {NULL, NULL}; - i = 1; + Tcl_Size i = 1; while (++i < objc) { + Tcl_Obj **lstv; + Tcl_Size lstc; if (TclListObjGetElements(interp, objv[i], &lstc, &lstv) != TCL_OK) { return TCL_ERROR; @@ -542,6 +542,8 @@ TclStrIdxTreeTestObjCmd( TclStrIdxTreeFree(idxTree.firstPtr); break; } + default: + TCL_UNREACHABLE(); } return TCL_OK; diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index 2378d96..dc329be 100644 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -1515,7 +1515,7 @@ TclParseNumber( #endif case INITIAL: /* This case only to silence compiler warning. */ - Tcl_Panic("TclParseNumber: state INITIAL can't happen here"); + TCL_UNREACHABLE(); } } diff --git a/generic/tclTimer.c b/generic/tclTimer.c index 2c566f6..1fc7620 100644 --- a/generic/tclTimer.c +++ b/generic/tclTimer.c @@ -979,7 +979,7 @@ Tcl_AfterObjCmd( } break; default: - Tcl_Panic("Tcl_AfterObjCmd: bad subcommand index to afterSubCmds"); + TCL_UNREACHABLE(); } return TCL_OK; } diff --git a/generic/tclTrace.c b/generic/tclTrace.c index eb582e6..7aa31dd 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -250,9 +250,9 @@ Tcl_TraceObjCmd( return TCL_ERROR; } return traceSubCmds[typeIndex](interp, optionIndex, objc, objv); - break; } - + default: + TCL_UNREACHABLE(); } return TCL_OK; } @@ -344,6 +344,8 @@ TraceExecutionObjCmd( case TRACE_EXEC_LEAVE_STEP: flags |= TCL_TRACE_LEAVE_DURING_EXEC; break; + default: + TCL_UNREACHABLE(); } } command = TclGetStringFromObj(objv[5], &length); @@ -500,6 +502,8 @@ TraceExecutionObjCmd( Tcl_SetObjResult(interp, resultListPtr); break; } + default: + TCL_UNREACHABLE(); } return TCL_OK; } @@ -580,6 +584,8 @@ TraceCommandObjCmd( case TRACE_CMD_DELETE: flags |= TCL_TRACE_DELETE; break; + default: + TCL_UNREACHABLE(); } } @@ -694,6 +700,8 @@ TraceCommandObjCmd( Tcl_SetObjResult(interp, resultListPtr); break; } + default: + TCL_UNREACHABLE(); } return TCL_OK; } @@ -785,6 +793,8 @@ TraceVariableObjCmd( case TRACE_VAR_WRITE: flags |= TCL_TRACE_WRITES; break; + default: + TCL_UNREACHABLE(); } } command = TclGetStringFromObj(objv[5], &length); @@ -878,6 +888,8 @@ TraceVariableObjCmd( Tcl_SetObjResult(interp, resultListPtr); break; } + default: + TCL_UNREACHABLE(); } return TCL_OK; } diff --git a/generic/tclVar.c b/generic/tclVar.c index f2bd26b..c337cc3 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -3945,6 +3945,8 @@ ArrayNamesCmd( return TCL_ERROR; } break; + default: + TCL_UNREACHABLE(); } if (matched == 0) { continue; @@ -6980,10 +6982,10 @@ ArrayDefaultCmd( SetArrayDefault(varPtr, NULL); } return TCL_OK; - } - /* Unreached */ - return TCL_ERROR; + default: + TCL_UNREACHABLE(); + } } /* diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index d946372..8fc77ba 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -4256,6 +4256,8 @@ ZipFSListObjCmd( return TCL_ERROR; } break; + default: + TCL_UNREACHABLE(); } } else if (objc == 2) { pattern = TclGetString(objv[1]); diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 4bf2e61..538a943 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -395,9 +395,7 @@ ConvertErrorToList( */ default: - TclNewLiteralStringObj(objv[2], "UNKNOWN"); - TclNewIntObj(objv[3], code); - return Tcl_NewListObj(4, objv); + TCL_UNREACHABLE(); } } @@ -2105,10 +2103,10 @@ ZlibCmd( return TCL_ERROR; } switch (option) { - case 0: + case 0: // -header headerDictObj = objv[i + 1]; break; - case 1: + case 1: // -level if (Tcl_GetIntFromObj(interp, objv[i + 1], &level) != TCL_OK) { return TCL_ERROR; @@ -2118,6 +2116,8 @@ ZlibCmd( goto badLevel; } break; + default: + TCL_UNREACHABLE(); } } return Tcl_ZlibDeflate(interp, TCL_ZLIB_FORMAT_GZIP, objv[2], level, @@ -2179,7 +2179,7 @@ ZlibCmd( return TCL_ERROR; } switch (option) { - case 0: + case 0: // -buffersize if (TclGetWideIntFromObj(interp, objv[i + 1], &wideLen) != TCL_OK) { return TCL_ERROR; @@ -2190,10 +2190,12 @@ ZlibCmd( } buffersize = wideLen; break; - case 1: + case 1: // -headerVar headerVarObj = objv[i + 1]; TclNewObj(headerDictObj); break; + default: + TCL_UNREACHABLE(); } } if (Tcl_ZlibInflate(interp, TCL_ZLIB_FORMAT_GZIP, objv[2], @@ -2215,9 +2217,10 @@ ZlibCmd( case CMD_PUSH: /* push mode channel options... * -> channel */ return ZlibPushSubcmd(interp, objc, objv); - } - return TCL_ERROR; + default: // Should be no other options + TCL_UNREACHABLE(); + } badLevel: Tcl_SetObjResult(interp, Tcl_NewStringObj( @@ -2340,7 +2343,7 @@ ZlibStreamSubcmd( format = TCL_ZLIB_FORMAT_GZIP; break; default: - Tcl_Panic("should be unreachable"); + TCL_UNREACHABLE(); } /* @@ -2472,7 +2475,7 @@ ZlibPushSubcmd( format = TCL_ZLIB_FORMAT_GZIP; break; default: - Tcl_Panic("should be unreachable"); + TCL_UNREACHABLE(); } if (TclGetChannelFromObj(interp, objv[3], &chan, &chanMode, 0) != TCL_OK) { @@ -2555,6 +2558,8 @@ ZlibPushSubcmd( } compDictObj = objv[i]; break; + default: + TCL_UNREACHABLE(); } } @@ -2708,9 +2713,9 @@ ZlibStreamCmd( return TCL_ERROR; } return Tcl_ZlibStreamReset(zstream); + default: + TCL_UNREACHABLE(); } - - return TCL_OK; } static int @@ -2787,6 +2792,8 @@ ZlibStreamAddCmd( } compDictObj = objv[++i]; break; + default: + TCL_UNREACHABLE(); } if (flush == -2) { @@ -2895,6 +2902,8 @@ ZlibStreamPutCmd( } compDictObj = objv[++i]; break; + default: + TCL_UNREACHABLE(); } if (flush == -2) { Tcl_SetObjResult(interp, Tcl_NewStringObj( -- cgit v0.12 From 5f4f0bf1e62f112199a79208b8cce3b502f4f779 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 27 May 2025 19:11:46 +0000 Subject: More marking of paths as unreachable --- generic/tclClockFmt.c | 92 ++++++++++++++++++++++++++++----------------------- generic/tclCmdIL.c | 6 ---- generic/tclCompile.c | 6 ++++ generic/tclDate.h | 2 +- generic/tclExecute.c | 2 -- generic/tclPathObj.c | 5 +-- 6 files changed, 59 insertions(+), 54 deletions(-) diff --git a/generic/tclClockFmt.c b/generic/tclClockFmt.c index 1fcf1fb..f6aa440 100644 --- a/generic/tclClockFmt.c +++ b/generic/tclClockFmt.c @@ -1027,7 +1027,7 @@ static const char * FindTokenBegin( const char *p, const char *end, - ClockScanToken *tok, + const ClockScanToken *tok, int flags) { if (p < end) { @@ -1040,10 +1040,14 @@ FindTokenBegin( if (!(flags & CLF_STRICT)) { /* should match at least one digit or space */ while (!isdigit(UCHAR(*p)) && !isspace(UCHAR(*p)) && - (p = Tcl_UtfNext(p)) < end) {} + (p = Tcl_UtfNext(p)) < end) { + // Empty + } } else { /* should match at least one digit */ - while (!isdigit(UCHAR(*p)) && (p = Tcl_UtfNext(p)) < end) {} + while (!isdigit(UCHAR(*p)) && (p = Tcl_UtfNext(p)) < end) { + // Empty + } } return p; @@ -1052,19 +1056,25 @@ FindTokenBegin( goto findChar; case CTOKT_SPACE: - while (!isspace(UCHAR(*p)) && (p = Tcl_UtfNext(p)) < end) {} + while (!isspace(UCHAR(*p)) && (p = Tcl_UtfNext(p)) < end) { + // Empty + } return p; case CTOKT_CHAR: c = *((char *)tok->map->data); -findChar: + findChar: if (!(flags & CLF_STRICT)) { /* should match the char or space */ while (*p != c && !isspace(UCHAR(*p)) && - (p = Tcl_UtfNext(p)) < end) {} + (p = Tcl_UtfNext(p)) < end) { + // Empty + } } else { /* should match the char */ - while (*p != c && (p = Tcl_UtfNext(p)) < end) {} + while (*p != c && (p = Tcl_UtfNext(p)) < end) { + // Empty + } } return p; } @@ -1092,7 +1102,7 @@ static void DetermineGreedySearchLen( ClockFmtScnCmdArgs *opts, DateInfo *info, - ClockScanToken *tok, + const ClockScanToken *tok, int *minLenPtr, int *maxLenPtr) { @@ -1144,7 +1154,7 @@ DetermineGreedySearchLen( /* try to get max length more precise for greedy match, * check the next ahead token available there */ if (minLen < maxLen && tok->lookAhTok) { - ClockScanToken *laTok = tok + tok->lookAhTok + 1; + const ClockScanToken *laTok = tok + tok->lookAhTok + 1; p = yyInput + maxLen; /* regards all possible spaces here (because they are optional) */ @@ -1158,7 +1168,7 @@ DetermineGreedySearchLen( /* try to find laTok between [lookAhMin, lookAhMax] */ while (minLen < maxLen) { const char *f = FindTokenBegin(p, end, laTok, - TCL_CLOCK_FULL_COMPAT ? opts->flags : CLF_STRICT); + TCL_CLOCK_FULL_COMPAT ? opts->flags : CLF_STRICT); /* if found (not below lookAhMax) */ if (f < end) { break; @@ -1494,7 +1504,7 @@ StaticListSearch( static inline const char * FindWordEnd( - ClockScanToken *tok, + const ClockScanToken *tok, const char *p, const char *end) { @@ -1519,7 +1529,7 @@ static int ClockScnToken_Month_Proc( ClockFmtScnCmdArgs *opts, DateInfo *info, - ClockScanToken *tok) + const ClockScanToken *tok) { #if 0 /* currently unused, test purposes only */ @@ -1569,7 +1579,7 @@ static int ClockScnToken_DayOfWeek_Proc( ClockFmtScnCmdArgs *opts, DateInfo *info, - ClockScanToken *tok) + const ClockScanToken *tok) { static int dowKeys[] = {MCLIT_DAYS_OF_WEEK_ABBREV, MCLIT_DAYS_OF_WEEK_FULL, 0}; @@ -1643,7 +1653,7 @@ static int ClockScnToken_amPmInd_Proc( ClockFmtScnCmdArgs *opts, DateInfo *info, - ClockScanToken *tok) + const ClockScanToken *tok) { int ret, val; int minLen, maxLen; @@ -1676,7 +1686,7 @@ static int ClockScnToken_LocaleERA_Proc( ClockFmtScnCmdArgs *opts, DateInfo *info, - ClockScanToken *tok) + const ClockScanToken *tok) { ClockClientData *dataPtr = opts->dataPtr; @@ -1715,7 +1725,7 @@ static int ClockScnToken_LocaleListMatcher_Proc( ClockFmtScnCmdArgs *opts, DateInfo *info, - ClockScanToken *tok) + const ClockScanToken *tok) { int ret, val; int minLen, maxLen; @@ -1746,7 +1756,7 @@ static int ClockScnToken_JDN_Proc( ClockFmtScnCmdArgs *opts, DateInfo *info, - ClockScanToken *tok) + const ClockScanToken *tok) { int minLen, maxLen; const char *p = yyInput, *end, *s; @@ -1817,7 +1827,7 @@ static int ClockScnToken_TimeZone_Proc( ClockFmtScnCmdArgs *opts, DateInfo *info, - ClockScanToken *tok) + const ClockScanToken *tok) { int minLen, maxLen; int len = 0; @@ -1909,7 +1919,7 @@ static int ClockScnToken_StarDate_Proc( ClockFmtScnCmdArgs *opts, DateInfo *info, - ClockScanToken *tok) + const ClockScanToken *tok) { int minLen, maxLen; const char *p = yyInput, *end, *s; @@ -2304,29 +2314,27 @@ ClockGetOrParseScanFormat( continue; } word_tok: - { - /* try continue with previous word token */ - ClockScanToken *wordTok = tok - 1; - - if (wordTok < scnTok || wordTok->map != &ScnWordTokenMap) { - /* start with new word token */ - wordTok = tok; - wordTok->tokWord.start = p; - wordTok->map = &ScnWordTokenMap; - } + /* try continue with previous word token */ + ClockScanToken *wordTok = tok - 1; - do { - if (isspace(UCHAR(*p))) { - fss->scnSpaceCount++; - } - p = Tcl_UtfNext(p); - } while (p < e && *p != '%'); - wordTok->tokWord.end = p; + if (wordTok < scnTok || wordTok->map != &ScnWordTokenMap) { + /* start with new word token */ + wordTok = tok; + wordTok->tokWord.start = p; + wordTok->map = &ScnWordTokenMap; + } - if (wordTok == tok) { - AllocTokenInChain(tok, scnTok, fss->scnTokC, ClockScanToken *); - tokCnt++; + do { + if (isspace(UCHAR(*p))) { + fss->scnSpaceCount++; } + p = Tcl_UtfNext(p); + } while (p < e && *p != '%'); + wordTok->tokWord.end = p; + + if (wordTok == tok) { + AllocTokenInChain(tok, scnTok, fss->scnTokC, ClockScanToken *); + tokCnt++; } break; } @@ -2376,8 +2384,8 @@ ClockScan( ClockFmtScnCmdArgs *opts) /* Command options */ { ClockClientData *dataPtr = opts->dataPtr; - ClockFmtScnStorage *fss; - ClockScanToken *tok; + const ClockFmtScnStorage *fss; + const ClockScanToken *tok; const ClockScanTokenMap *map; const char *p, *x, *end; unsigned short flags = 0; @@ -2557,6 +2565,8 @@ ClockScan( } p++; break; + default: + TCL_UNREACHABLE(); } } /* check end was reached */ diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index b4d2eb3..3b415b7 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -4280,10 +4280,8 @@ Tcl_LseqObjCmd( case LSEQ_BY: /* Error case */ goto syntax; - break; default: goto syntax; - break; } break; @@ -4301,7 +4299,6 @@ Tcl_LseqObjCmd( case LSEQ_COUNT: default: goto syntax; - break; } break; @@ -4316,7 +4313,6 @@ Tcl_LseqObjCmd( break; default: goto syntax; - break; } opmode = (SequenceOperators)values[1]; switch (opmode) { @@ -4331,7 +4327,6 @@ Tcl_LseqObjCmd( break; default: goto syntax; - break; } break; @@ -4340,7 +4335,6 @@ Tcl_LseqObjCmd( syntax: Tcl_WrongNumArgs(interp, 1, objv, "n ??op? n ??by? n??"); goto done; - break; } /* Count needs to be integer, so try to convert if possible */ diff --git a/generic/tclCompile.c b/generic/tclCompile.c index bdc6298..a389418 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1494,12 +1494,18 @@ IsCompactibleCompileEnv( case INST_EVAL_STK: case INST_EXPR_STK: case INST_YIELD: + case INST_YIELD_TO_INVOKE: return 0; /* Upvars */ case INST_UPVAR: case INST_NSUPVAR: case INST_VARIABLE: return 0; + /* TclOO::next is NOT a problem: puts stack frame out of way. + * There's a way to do it, but it's beneath the threshold of + * likelihood. */ + case INST_TCLOO_NEXT: + case INST_TCLOO_NEXT_CLASS: default: size = tclInstructionTable[*pc].numBytes; assert (size > 0); diff --git a/generic/tclDate.h b/generic/tclDate.h index a63eb0e..366ae59 100644 --- a/generic/tclDate.h +++ b/generic/tclDate.h @@ -393,7 +393,7 @@ typedef struct ClockScanToken ClockScanToken; typedef int ClockScanTokenProc( ClockFmtScnCmdArgs *opts, DateInfo *info, - ClockScanToken *tok); + const ClockScanToken *tok); typedef enum _CLCKTOK_TYPE { CTOKT_INT = 1, CTOKT_WIDE, CTOKT_PARSER, CTOKT_SPACE, CTOKT_WORD, CTOKT_CHAR, diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 504fc8d..13dd5e9 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -7170,7 +7170,6 @@ TEBCresume( &OBJ_AT_DEPTH(numArgs - 1)); break; default: - Tcl_Panic("Should not happen!"); TCL_UNREACHABLE(); } @@ -7312,7 +7311,6 @@ TEBCresume( } break; default: - Tcl_Panic("Should not happen!"); TCL_UNREACHABLE(); } diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index 6ed712e..be64423 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -680,10 +680,7 @@ TclPathPart( } } default: - /* We should never get here */ - Tcl_Panic("Bad portion to TclPathPart"); - /* For less clever compilers */ - return NULL; + TCL_UNREACHABLE(); } } else if (fsPathPtr->cwdPtr != NULL) { /* Relative path */ -- cgit v0.12 From 14e9c92103399765e897dabd491d286935559254 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 29 May 2025 08:13:56 +0000 Subject: more unreachable/fallthrough marks --- generic/tclBasic.c | 7 +++-- generic/tclClock.c | 3 +- generic/tclClockFmt.c | 2 +- generic/tclCmdAH.c | 1 + generic/tclCmdMZ.c | 5 +-- generic/tclCompCmdsGR.c | 1 + generic/tclCompile.c | 3 +- generic/tclDictObj.c | 3 +- generic/tclDisassemble.c | 42 ++++++++++++++++--------- generic/tclEncoding.c | 6 ++-- generic/tclExecute.c | 79 +++++++++++++++++++++--------------------------- generic/tclIOCmd.c | 2 +- generic/tclIcu.c | 9 +++--- generic/tclInt.h | 11 +++++++ generic/tclLink.c | 2 +- generic/tclOOCall.c | 6 ++-- generic/tclParse.c | 11 +++++-- generic/tclProc.c | 6 ++-- generic/tclScan.c | 14 ++++----- generic/tclStrToD.c | 51 +++++++++++++++++++------------ generic/tclStringObj.c | 20 +++++++----- generic/tclTest.c | 2 +- generic/tclUtil.c | 6 ++-- unix/tclUnixChan.c | 12 ++++---- win/tclWinPipe.c | 2 +- 25 files changed, 176 insertions(+), 130 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index e8ff787..288d64f 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4619,7 +4619,8 @@ Dispatch( } if (TCL_DTRACE_CMD_INFO_ENABLED() && iPtr->cmdFramePtr) { Tcl_Obj *info = TclInfoFrame(interp, iPtr->cmdFramePtr); - const char *a[6]; Tcl_Size i[2]; + const char *a[6]; + Tcl_Size i[2]; TclDTraceInfo(info, a, i); TCL_DTRACE_CMD_INFO(a[0], a[1], a[2], a[3], i[0], i[1], a[4], a[5]); @@ -6547,7 +6548,7 @@ Tcl_ExprLongObj( } resultPtr = Tcl_NewBignumObj(&big); } - /* FALLTHRU */ + TCL_FALLTHROUGH(); case TCL_NUMBER_INT: case TCL_NUMBER_BIG: result = TclGetLongFromObj(interp, resultPtr, ptr); @@ -9613,7 +9614,7 @@ TclNRInterpCoroutine( Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", (char *)NULL); return TCL_ERROR; } - /* fallthrough */ + TCL_FALLTHROUGH(); case COROUTINE_ARGUMENTS_ARBITRARY: if (objc > 1) { Tcl_SetObjResult(interp, Tcl_NewListObj(objc - 1, objv + 1)); diff --git a/generic/tclClock.c b/generic/tclClock.c index 9f658cd..6f19214 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -3630,7 +3630,8 @@ ClockScanObjCmd( } /* seconds are in localSeconds (relative base date), so reset time here */ - yyHour = yyMinutes = yySeconds = yySecondOfDay = 0; yyMeridian = MER24; + yyHour = yyMinutes = yySeconds = yySecondOfDay = 0; + yyMeridian = MER24; /* If free scan */ if (opts.formatObj == NULL) { diff --git a/generic/tclClockFmt.c b/generic/tclClockFmt.c index f6aa440..5e707cc 100644 --- a/generic/tclClockFmt.c +++ b/generic/tclClockFmt.c @@ -2615,7 +2615,7 @@ ClockScan( case (CLF_DAYOFYEAR | CLF_DAYOFMONTH): /* miss month: ddd over dd (without month) */ flags &= ~CLF_DAYOFMONTH; - /* fallthrough */ + TCL_FALLTHROUGH(); case CLF_DAYOFYEAR: /* ddd over naked weekday */ if (!(flags & CLF_ISO8601YEAR)) { diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 1f13529..8acd5be 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -2926,6 +2926,7 @@ ForeachLoopStep( "\n (\"%s\" body line %d)", (statePtr->resultList != NULL ? "lmap" : "foreach"), Tcl_GetErrorLine(interp))); + TCL_FALLTHROUGH(); default: goto done; } diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 6ea259b..79ae121 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -4420,7 +4420,7 @@ Tcl_TimeRateObjCmd( */ threshold = 1; maxcnt = 0; - /* FALLTHRU */ + TCL_FALLTHROUGH(); case TCL_CONTINUE: result = TCL_OK; break; @@ -4509,7 +4509,8 @@ Tcl_TimeRateObjCmd( lastIterTm = avgIterTm; } estIterTm *= lastIterTm; - last = middle; lastCount = count; + last = middle; + lastCount = count; /* * Calculate next threshold to check. diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index f8390cf..4a74299 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -2160,6 +2160,7 @@ TclCompileRegsubCmd( * but we definitely can't handle that at all. */ } + TCL_FALLTHROUGH(); case '\0': case '?': case '[': case '\\': goto done; } diff --git a/generic/tclCompile.c b/generic/tclCompile.c index a389418..d7437b3 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -3783,7 +3783,8 @@ TclGetInnermostExceptionRange( ExceptionRange *rangePtr = envPtr->exceptArrayPtr + i; while (i > 0) { - rangePtr--; i--; + rangePtr--; + i--; if (CurrentOffset(envPtr) >= rangePtr->codeOffset && (rangePtr->numCodeBytes == TCL_INDEX_NONE || CurrentOffset(envPtr) < diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 7d7c359..2c74c1b 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -3424,7 +3424,7 @@ DictFilterCmd( Tcl_ResetResult(interp); Tcl_DictObjDone(&search); - /* FALLTHRU */ + TCL_FALLTHROUGH(); case TCL_CONTINUE: result = TCL_OK; break; @@ -3432,6 +3432,7 @@ DictFilterCmd( Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (\"dict filter\" script line %d)", Tcl_GetErrorLine(interp))); + TCL_FALLTHROUGH(); default: goto abnormalResult; } diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index 98290d1..0bf5766 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -578,19 +578,23 @@ 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), @@ -599,12 +603,14 @@ FormatInstruction( 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); @@ -615,22 +621,26 @@ FormatInstruction( 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) { @@ -667,16 +677,19 @@ 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++; + opnd = TclGetUInt1AtPtr(pc+numBytes); + numBytes++; Tcl_AppendPrintfToObj(bufferObj, "silent=%s ", opnd?"no":"yes"); break; case OPERAND_CLK1: - opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++; + opnd = TclGetUInt1AtPtr(pc+numBytes); + numBytes++; switch (opnd) { case CLOCK_READ_CLICKS: Tcl_AppendPrintfToObj(bufferObj, "clicks " ); @@ -695,7 +708,8 @@ FormatInstruction( } break; case OPERAND_LRPL1: - opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++; + opnd = TclGetUInt1AtPtr(pc+numBytes); + numBytes++; switch (opnd) { case 0: Tcl_AppendPrintfToObj(bufferObj, "0 "); diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 2710c3f..eeb86d9 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -2582,7 +2582,8 @@ UtfToUtfProc( } else { /* TCL_ENCODING_PROFILE_TCL8 */ char chbuf[2]; - chbuf[0] = UCHAR(*src++); chbuf[1] = 0; + chbuf[0] = UCHAR(*src++); + chbuf[1] = 0; TclUtfToUniChar(chbuf, &ch); } dst += Tcl_UniCharToUtf(ch, dst); @@ -3508,7 +3509,8 @@ TableToUtfProc( ch = UNICODE_REPLACE_CHAR; } else { char chbuf[2]; - chbuf[0] = byte; chbuf[1] = 0; + chbuf[0] = byte; + chbuf[1] = 0; TclUtfToUniChar(chbuf, &ch); } } diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 13dd5e9..244c8a3 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -2216,12 +2216,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; @@ -2238,17 +2238,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 @@ -4453,20 +4453,11 @@ TEBCresume( codePtr->auxDataArrayPtr[tblIdx].clientData; TRACE(("%u \"%.20s\" => ", tblIdx, O2S(OBJ_AT_TOS))); hPtr = Tcl_FindHashEntry(&jtPtr->hashTable, TclGetString(OBJ_AT_TOS)); - if (hPtr != NULL) { - Tcl_Size jumpOffset = PTR2INT(Tcl_GetHashValue(hPtr)); - - TRACE_APPEND(("found in table, new pc %" SIZEu "\n", - PC_REL + jumpOffset)); - NEXT_INST_F0(jumpOffset, 1); - } else { - TRACE_APPEND(("not found in table\n")); - NEXT_INST_F0(5, 1); - } + goto processJumpTableEntry; /* * Jump to location looked up in a hashtable; fall through to next - * instr if lookup fails. Lookup by integer. + * instr if lookup fails or key is non-integer. Lookup by integer. */ case INST_JUMP_TABLE_NUM: @@ -4479,17 +4470,18 @@ TEBCresume( goto jumpTableNumFallthrough; } hPtr = Tcl_FindHashEntry(&jtnPtr->hashTable, (void *)key); + + processJumpTableEntry: if (hPtr != NULL) { Tcl_Size jumpOffset = PTR2INT(Tcl_GetHashValue(hPtr)); TRACE_APPEND(("found in table, new pc %" SIZEu "\n", PC_REL + jumpOffset)); NEXT_INST_F0(jumpOffset, 1); - } else { - jumpTableNumFallthrough: - TRACE_APPEND(("not found in table\n")); - NEXT_INST_F0(5, 1); } + jumpTableNumFallthrough: + TRACE_APPEND(("not found in table\n")); + NEXT_INST_F0(5, 1); } /* @@ -6476,7 +6468,9 @@ TEBCresume( TRACE_APPEND_NUM_OBJ(valuePtr); NEXT_INST_F0(1, 0); } - /* FALLTHROUGH */ + TCL_FALLTHROUGH(); + default: + break; } objResultPtr = ExecuteExtendedUnaryMathOp(*pc, valuePtr); if (objResultPtr != NULL) { @@ -6688,6 +6682,7 @@ TEBCresume( */ pc += 5 - infoPtr->loopCtTemp; + TCL_FALLTHROUGH(); case INST_FOREACH_STEP: /* TODO: address abstract list indexing here! */ /* @@ -6802,10 +6797,8 @@ TEBCresume( #ifdef TCL_COMPILE_DEBUG 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 */ @@ -8471,14 +8464,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) { @@ -8564,7 +8557,7 @@ ExecuteExtendedBinaryMathOp( if (oddExponent) { WIDE_RESULT(-1); } - /* fallthrough */ + TCL_FALLTHROUGH(); case 1: /* * 1 to any power is 1. @@ -8575,7 +8568,6 @@ ExecuteExtendedBinaryMathOp( } } if (negativeExponent) { - /* * Integers with magnitude greater than 1 raise to a negative * power yield the answer zero (see TIP 123). @@ -8588,23 +8580,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); } /* @@ -9045,7 +9037,6 @@ TclCompareTwoNumbers( default: TCL_UNREACHABLE(); } - break; case TCL_NUMBER_DOUBLE: d1 = *((const double *)ptr1); @@ -9094,7 +9085,6 @@ TclCompareTwoNumbers( default: TCL_UNREACHABLE(); } - break; case TCL_NUMBER_BIG: Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); @@ -9133,7 +9123,6 @@ TclCompareTwoNumbers( default: TCL_UNREACHABLE(); } - break; default: Tcl_Panic("unexpected number type"); TCL_UNREACHABLE(); diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index 8735627..ed5c938 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -135,7 +135,7 @@ Tcl_PutsObjCmd( string = objv[3]; break; } - /* Fall through */ + TCL_FALLTHROUGH(); default: /* [puts] or * [puts some bad number of arguments...] */ Tcl_WrongNumArgs(interp, 1, objv, "?-nonewline? ?channel? string"); diff --git a/generic/tclIcu.c b/generic/tclIcu.c index d2d0f09..0f73875 100644 --- a/generic/tclIcu.c +++ b/generic/tclIcu.c @@ -761,7 +761,7 @@ IcuConverttoDString( if (U_SUCCESS(status)) { break; } - /* FALLTHRU */ + TCL_FALLTHROUGH(); default: Tcl_DStringFree(dsOutPtr); ucnv_close(ucnvPtr); @@ -841,7 +841,7 @@ IcuBytesToUCharDString( if (U_SUCCESS(status)) { break; } - /* FALLTHRU */ + TCL_FALLTHROUGH(); default: Tcl_DStringFree(dsOutPtr); ucnv_close(ucnvPtr); @@ -937,7 +937,7 @@ IcuNormalizeUCharDString( if (U_SUCCESS(status)) { break; } - /* FALLTHRU */ + TCL_FALLTHROUGH(); default: Tcl_DStringFree(dsOutPtr); return IcuError(interp, "String normalization failed", status); @@ -1327,7 +1327,8 @@ TclIcuInit( /* Going back down to ICU version 60 */ while ((icu_fns.libs[0] == NULL) && (icuversion[1] >= '6')) { if (--icuversion[2] < '0') { - icuversion[1]--; icuversion[2] = '9'; + icuversion[1]--; + icuversion[2] = '9'; } #if defined(__CYGWIN__) i = 2; diff --git a/generic/tclInt.h b/generic/tclInt.h index c50462f..3f4d23f 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -156,6 +156,17 @@ #endif #endif // TCL_UNREACHABLE +#ifndef TCL_FALLTHROUGH +#if defined(__STDC__) && __STDC__ >= 202311L +#define TCL_FALLTHROUGH() [[fallthrough]] +#elif defined(__GNUC__) +#define TCL_FALLTHROUGH() __attribute__((fallthrough)) +#else +// Nothing documented as an alternative to the standard [[fallthrough]]. +#define TCL_FALLTHROUGH() ((void) 0) +#endif +#endif // TCL_FALLTHROUGH + /* * The following procedures allow namespaces to be customized to support * special name resolution rules for commands/variables. diff --git a/generic/tclLink.c b/generic/tclLink.c index 14bb663..57bad3c 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -1316,7 +1316,7 @@ ObjValue( Tcl_Obj *uwObj; TclNewUIntObj(uwObj, linkPtr->lastValue.uw); return uwObj; - } + } case TCL_LINK_STRING: p = LinkedVar(char *); diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index fe44bed..80a4dbe 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -1644,6 +1644,7 @@ AddClassFiltersToCallContext( AddClassFiltersToCallContext(oPtr, superPtr, cbPtr, doneFilters, flags); } + TCL_FALLTHROUGH(); case 0: return; } @@ -1731,7 +1732,7 @@ AddPrivatesFromClassChainToCallContext( return 1; } } - /* FALLTHRU */ + TCL_FALLTHROUGH(); case 0: return 0; } @@ -1826,7 +1827,7 @@ AddSimpleClassChainToCallContext( privateDanger |= AddSimpleClassChainToCallContext(superPtr, methodNameObj, cbPtr, doneFilters, flags, filterDecl); } - /* FALLTHRU */ + TCL_FALLTHROUGH(); case 0: return privateDanger; } @@ -2064,6 +2065,7 @@ AddSimpleClassDefineNamespaces( FOREACH(superPtr, classPtr->superclasses) { AddSimpleClassDefineNamespaces(superPtr, definePtr, flags); } + TCL_FALLTHROUGH(); case 0: return; } diff --git a/generic/tclParse.c b/generic/tclParse.c index ec9f61c..3f9b0d8 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -1381,7 +1381,8 @@ Tcl_ParseVarName( */ if (*src == '{') { - char ch; int braceCount = 0; + char ch; + int braceCount = 0; src++; numBytes--; tokenPtr->type = TCL_TOKEN_TEXT; @@ -1391,8 +1392,12 @@ Tcl_ParseVarName( ch = *src; while (numBytes && (braceCount>0 || ch != '}')) { switch (ch) { - case '{': braceCount++; break; - case '}': braceCount--; break; + case '{': + braceCount++; + break; + case '}': + braceCount--; + break; case '\\': /* if 2 or more left, consume 2, else consume * just the \ and let it run into the end */ diff --git a/generic/tclProc.c b/generic/tclProc.c index b3128dc..5b74ea1 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -1762,7 +1762,8 @@ TclNRInterpProcCore( } if (TCL_DTRACE_PROC_INFO_ENABLED() && iPtr->cmdFramePtr) { Tcl_Obj *info = TclInfoFrame(interp, iPtr->cmdFramePtr); - const char *a[6]; Tcl_Size i[2]; + const char *a[6]; + Tcl_Size i[2]; TclDTraceInfo(info, a, i); TCL_DTRACE_PROC_INFO(a[0], a[1], a[2], a[3], i[0], i[1], a[4], a[5]); @@ -1875,8 +1876,7 @@ InterpProcNR2( ((result == TCL_BREAK) ? "break" : "continue"))); Tcl_SetErrorCode(interp, "TCL", "RESULT", "UNEXPECTED", (char *)NULL); result = TCL_ERROR; - - /* FALLTHRU */ + TCL_FALLTHROUGH(); case TCL_ERROR: /* diff --git a/generic/tclScan.c b/generic/tclScan.c index ba7cb72..feddedc 100644 --- a/generic/tclScan.c +++ b/generic/tclScan.c @@ -396,11 +396,11 @@ ValidateFormat( format += TclUtfToUniChar(format, &ch); break; } - /* FALLTHRU */ + TCL_FALLTHROUGH(); case 'j': case 'q': flags |= SCAN_LONGER; - /* FALLTHRU */ + TCL_FALLTHROUGH(); case 'h': format += TclUtfToUniChar(format, &ch); } @@ -422,7 +422,7 @@ ValidateFormat( Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADWIDTH", (char *)NULL); goto error; } - /* FALLTHRU */ + TCL_FALLTHROUGH(); case 'n': case 's': if (flags & (SCAN_LONGER|SCAN_BIG)) { @@ -436,9 +436,7 @@ ValidateFormat( Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADSIZE", (char *)NULL); goto error; } - /* - * Fall through! - */ + TCL_FALLTHROUGH(); case 'd': case 'e': case 'E': @@ -749,11 +747,11 @@ Tcl_ScanObjCmd( format += TclUtfToUniChar(format, &ch); break; } - /* FALLTHRU */ + TCL_FALLTHROUGH(); case 'j': case 'q': flags |= SCAN_LONGER; - /* FALLTHRU */ + TCL_FALLTHROUGH(); case 'h': format += TclUtfToUniChar(format, &ch); } diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index dc329be..e1763a8 100644 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -672,7 +672,7 @@ TclParseNumber( state = SIGNUM; break; } - /* FALLTHROUGH */ + TCL_FALLTHROUGH(); case SIGNUM: /* @@ -768,7 +768,7 @@ TclParseNumber( acceptState = state; acceptPoint = p; acceptLen = len; - /* FALLTHROUGH */ + TCL_FALLTHROUGH(); case ZERO_O: zeroo: if (c == '0') { @@ -847,7 +847,7 @@ TclParseNumber( acceptState = state; acceptPoint = p; acceptLen = len; - /* FALLTHROUGH */ + TCL_FALLTHROUGH(); case ZERO_X: zerox: @@ -911,7 +911,7 @@ TclParseNumber( acceptState = state; acceptPoint = p; acceptLen = len; - /* FALLTHRU */ + TCL_FALLTHROUGH(); case ZERO_B: zerob: if (c == '0') { @@ -972,7 +972,7 @@ TclParseNumber( } state = DECIMAL; flags |= TCL_PARSE_INTEGER_ONLY; - /* FALLTHROUGH */ + TCL_FALLTHROUGH(); case DECIMAL: /* @@ -1024,7 +1024,7 @@ TclParseNumber( state = EXPONENT_START; break; } - /* FALLTHROUGH */ + TCL_FALLTHROUGH(); case LEADING_RADIX_POINT: if (c == '0') { @@ -1066,7 +1066,7 @@ TclParseNumber( state = EXPONENT_SIGNUM; break; } - /* FALLTHROUGH */ + TCL_FALLTHROUGH(); case EXPONENT_SIGNUM: /* @@ -1186,7 +1186,7 @@ TclParseNumber( state = sNANFINISH; break; } - /* FALLTHROUGH */ + TCL_FALLTHROUGH(); case sNANPAREN: if (TclIsSpaceProcM(c)) { break; @@ -2312,22 +2312,28 @@ NormalizeRightward( Tcl_WideUInt w = *wPtr; if (!(w & (Tcl_WideUInt) 0xFFFFFFFF)) { - w >>= 32; rv += 32; + w >>= 32; + rv += 32; } if (!(w & (Tcl_WideUInt) 0xFFFF)) { - w >>= 16; rv += 16; + w >>= 16; + rv += 16; } if (!(w & (Tcl_WideUInt) 0xFF)) { - w >>= 8; rv += 8; + w >>= 8; + rv += 8; } if (!(w & (Tcl_WideUInt) 0xF)) { - w >>= 4; rv += 4; + w >>= 4; + rv += 4; } if (!(w & 0x3)) { - w >>= 2; rv += 2; + w >>= 2; + rv += 2; } if (!(w & 0x1)) { - w >>= 1; ++rv; + w >>= 1; + ++rv; } *wPtr = w; return rv; @@ -3175,7 +3181,9 @@ ShorteningInt64Conversion( if (b < S) { b = 10 * b; - ++m2plus; ++m2minus; ++m5; + ++m2plus; + ++m2minus; + ++m5; ilim = ilim1; --k; } @@ -3554,7 +3562,9 @@ ShorteningBignumConversionPowD( if ((err == MP_OKAY) && (b.used <= sd)) { err = mp_mul_d(&b, 10, &b); - ++m2plus; ++m2minus; ++m5; + ++m2plus; + ++m2minus; + ++m5; ilim = ilim1; --k; } @@ -3594,7 +3604,8 @@ ShorteningBignumConversionPowD( if (b.used > sd+1 || digit >= 10) { Tcl_Panic("wrong digit!"); } - --b.used; mp_clamp(&b); + --b.used; + mp_clamp(&b); } /* @@ -4570,9 +4581,11 @@ TclDoubleDigits( */ if (b2 >= s2 && s2 > 0) { - b2 -= s2; s2 = 0; + b2 -= s2; + s2 = 0; } else if (s2 >= b2 && b2 > 0) { - s2 -= b2; b2 = 0; + s2 -= b2; + b2 = 0; } if (s5+1 < N_LOG2POW5 && s2+1 + log2pow5[s5+1] < 64) { diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 73e9984..507012e 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -2165,7 +2165,6 @@ Tcl_AppendFormatToObj( } case 'u': - /* FALLTHRU */ case 'd': case 'o': case 'p': @@ -2773,7 +2772,7 @@ AppendPrintfToObjVA( if (sizeof(size_t) == sizeof(Tcl_WideInt)) { size = 2; } - /* FALLTHRU */ + TCL_FALLTHROUGH(); case 'c': case 'i': case 'u': @@ -2868,7 +2867,7 @@ AppendPrintfToObjVA( break; case 'h': size = -1; - /* FALLTHRU */ + TCL_FALLTHROUGH(); default: p++; } @@ -3272,7 +3271,8 @@ TclStringCat( } while (--oc); } else { /* Result will be concat of string reps. Pre-size it. */ - ov = objv; oc = objc; + ov = objv; + oc = objc; do { Tcl_Obj *pendingPtr = NULL; @@ -3356,7 +3356,8 @@ TclStringCat( return objv[first]; } - objv += first; objc = (last - first + 1); + objv += first; + objc = (last - first + 1); inPlace = (flags & TCL_STRING_IN_PLACE) && !Tcl_IsShared(*objv); if (binary) { @@ -3371,7 +3372,8 @@ TclStringCat( if (inPlace) { Tcl_Size start = 0; - objResultPtr = *objv++; objc--; + objResultPtr = *objv++; + objc--; (void)Tcl_GetBytesFromObj(NULL, objResultPtr, &start); dst = Tcl_SetByteArrayLength(objResultPtr, length) + start; } else { @@ -3401,7 +3403,8 @@ TclStringCat( if (inPlace) { Tcl_Size start; - objResultPtr = *objv++; objc--; + objResultPtr = *objv++; + objc--; /* Ugly interface! Force resize of the unicode array. */ (void)Tcl_GetUnicodeFromObj(objResultPtr, &start); @@ -3452,7 +3455,8 @@ TclStringCat( if (inPlace) { Tcl_Size start; - objResultPtr = *objv++; objc--; + objResultPtr = *objv++; + objc--; (void)TclGetStringFromObj(objResultPtr, &start); if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) { diff --git a/generic/tclTest.c b/generic/tclTest.c index 2c876cf..62fa89d 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -8776,7 +8776,7 @@ TestLutilCmd( Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); break; } - /* FALLTHRU */ + TCL_FALLTHROUGH(); case LUTIL_DIFFINDEX: nCmp = nL1 <= nL2 ? nL1 : nL2; for (i = 0; i < nCmp; ++i) { diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 42ce39e..43e5185 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -1133,7 +1133,7 @@ TclScanElement( preferEscape = 1; break; #else - /* FLOW THROUGH */ + TCL_FALLTHROUGH(); #endif /* COMPAT */ case '[': /* TYPE_SUBS */ case '$': /* TYPE_SUBS */ @@ -4449,7 +4449,7 @@ TclReToGlob( case '\\': case '*': case '[': case ']': case '?': /* Only add \ where necessary for glob */ *dsStr++ = '\\'; - /* fall through */ + TCL_FALLTHROUGH(); default: *dsStr++ = *p; break; @@ -4530,7 +4530,7 @@ TclReToGlob( /* Only add \ where necessary for glob */ *dsStr++ = '\\'; anchorLeft = 0; /* prevent exact match */ - /* fall through */ + TCL_FALLTHROUGH(); case '{': case '}': case '(': case ')': case '+': case '.': case '|': case '^': case '$': *dsStr++ = *p; diff --git a/unix/tclUnixChan.c b/unix/tclUnixChan.c index 7389a3d..b256e77 100644 --- a/unix/tclUnixChan.c +++ b/unix/tclUnixChan.c @@ -1509,15 +1509,15 @@ TtyGetAttributes( parity = 'n'; #ifdef PAREXT switch ((int) (iostate.c_cflag & (PARENB | PARODD | PAREXT))) { - case PARENB : parity = 'e'; break; - case PARENB | PARODD : parity = 'o'; break; - case PARENB | PAREXT : parity = 's'; break; - case PARENB | PARODD | PAREXT : parity = 'm'; break; + case PARENB : parity = 'e'; break; + case PARENB | PARODD : parity = 'o'; break; + case PARENB | PAREXT : parity = 's'; break; + case PARENB | PARODD | PAREXT : parity = 'm'; break; } #else /* !PAREXT */ switch ((int) (iostate.c_cflag & (PARENB | PARODD))) { - case PARENB : parity = 'e'; break; - case PARENB | PARODD : parity = 'o'; break; + case PARENB : parity = 'e'; break; + case PARENB | PARODD : parity = 'o'; break; } #endif /* PAREXT */ diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c index efbac82..0846b17 100644 --- a/win/tclWinPipe.c +++ b/win/tclWinPipe.c @@ -3459,7 +3459,7 @@ TclPipeThreadStopSignal( SetEvent(evControl); *pipeTIPtr = NULL; - /* FALLTHRU */ + TCL_FALLTHROUGH(); case PTI_STATE_DOWN: return 1; -- cgit v0.12 From dfa57176349be86d31421494a6e994e137d1daed Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 29 May 2025 08:17:45 +0000 Subject: Apple's clang-pretending-to-be-gcc is slightly fussy --- generic/tclClockFmt.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/generic/tclClockFmt.c b/generic/tclClockFmt.c index 5e707cc..d531108 100644 --- a/generic/tclClockFmt.c +++ b/generic/tclClockFmt.c @@ -2313,7 +2313,7 @@ ClockGetOrParseScanFormat( tokCnt++; continue; } - word_tok: + word_tok: { /* try continue with previous word token */ ClockScanToken *wordTok = tok - 1; @@ -2338,6 +2338,7 @@ ClockGetOrParseScanFormat( } break; } + } } /* calculate end distance value for each tokens */ -- cgit v0.12 From c4d746554b140b56bbd49e70503ffff2abcb1e10 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 29 May 2025 15:07:03 +0000 Subject: put back accidentally removed code --- generic/tclEncoding.c | 24 ++++++++++++++++++++++++ generic/tclExecute.c | 7 +++++-- 2 files changed, 29 insertions(+), 2 deletions(-) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index eeb86d9..5002b87 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -4067,6 +4067,30 @@ EscapeToUtfProc( numChars++; } + if ((flags & TCL_ENCODING_END) && (result == TCL_CONVERT_MULTIBYTE)) { + /* We have a code fragment left-over at the end */ + if (dst > dstEnd) { + result = TCL_CONVERT_NOSPACE; + } else { + /* destination is not full, so we really are at the end now */ + if (PROFILE_STRICT(flags)) { + result = TCL_CONVERT_SYNTAX; + } else { + /* + * PROFILE_REPLACE or PROFILE_TCL8. The latter is treated + * similar to former because Tcl8 was broken in this regard + * as it just ignored the byte and truncated which is really + * a no-no as per Unicode recommendations. + */ + result = TCL_OK; + dst += Tcl_UniCharToUtf(UNICODE_REPLACE_CHAR, dst); + numChars++; + /* TCL_CONVERT_MULTIBYTE means all source consumed */ + src = srcEnd; + } + } + } + *statePtr = (Tcl_EncodingState) INT2PTR(state); *srcReadPtr = src - srcStart; *dstWrotePtr = dst - dstStart; diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 244c8a3..7ca2a54 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5496,6 +5496,7 @@ TEBCresume( objResultPtr = Tcl_DuplicateObj(valuePtr); slength = transform(TclGetString(objResultPtr)); Tcl_SetObjLength(objResultPtr, slength); + TclFreeInternalRep(objResultPtr); TRACE_APPEND_OBJ(objResultPtr); NEXT_INST_F(1, 1, 1); } else { @@ -7683,13 +7684,15 @@ TEBCresume( processExceptionReturn: #ifdef TCL_COMPILE_DEBUG switch (*pc) { +#ifndef REMOVE_DEPRECATED_OPCODES case INST_INVOKE_STK1: numArgs = TclGetUInt1AtPtr(pc + 1); - TRACE(("%u => ... after \"%.20s\": ", (unsigned)numArgs, cmdNameBuf)); + TRACE(("%u => ... after call: ", (unsigned)numArgs)); break; +#endif // REMOVE_DEPRECATED_OPCODES case INST_INVOKE_STK: numArgs = TclGetUInt4AtPtr(pc + 1); - TRACE(("%u => ... after \"%.20s\": ", (unsigned)numArgs, cmdNameBuf)); + TRACE(("%u => ... after call: ", (unsigned)numArgs)); break; case INST_EVAL_STK: /* -- cgit v0.12 From 6e2188ef57d274fcc3fad78a4d64b545f51b7f1d Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 29 May 2025 15:18:39 +0000 Subject: Go back to other way of working; actually more efficient in this case --- generic/tclExecute.c | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 31cf4ec..31c0cc6 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5487,10 +5487,11 @@ TEBCresume( valuePtr = OBJ_AT_TOS; TRACE(("\"%.30s\" => ", O2S(valuePtr))); if (Tcl_IsShared(valuePtr)) { - objResultPtr = Tcl_DuplicateObj(valuePtr); + // Make copy of UTF-8 representation ONLY; we're about to modify it + s1 = TclGetStringFromObj(valuePtr, &slength); + TclNewStringObj(objResultPtr, s1, slength); slength = transform(TclGetString(objResultPtr)); Tcl_SetObjLength(objResultPtr, slength); - TclFreeInternalRep(objResultPtr); TRACE_APPEND_OBJ(objResultPtr); NEXT_INST_F(1, 1, 1); } else { -- cgit v0.12 From c939f7497329c98f2ea2b41c6f285f11590d4057 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 29 May 2025 20:26:35 +0000 Subject: Don't read uninitialised memory; store in TEBCdata instead --- generic/tclExecute.c | 87 ++++++++++++++++++++++++++++++++++------------------ 1 file changed, 58 insertions(+), 29 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 31c0cc6..903210c 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -124,6 +124,9 @@ 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 */ @@ -1664,7 +1667,7 @@ TclCompileObj( if (!(codePtr->flags & TCL_BYTECODE_PRECOMPILED) && (codePtr->procPtr == NULL) && - (codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr)){ + (codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr)) { goto recompileObj; } @@ -1906,6 +1909,38 @@ ArgumentBCEnter( /* *---------------------------------------------------------------------- * + * 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 + +/* + *---------------------------------------------------------------------- + * * TclNRExecuteByteCode -- * * This procedure executes the instructions of a ByteCode structure. It @@ -1957,6 +1992,9 @@ TclNRExecuteByteCode( 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 @@ -2063,6 +2101,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. @@ -2096,9 +2135,6 @@ TEBCresume( unsigned tblIdx; int pcAdjustment; Var *varPtr, *arrayPtr; -#ifdef TCL_COMPILE_DEBUG - char cmdNameBuf[21]; -#endif #ifdef TCL_COMPILE_DEBUG int starting = 1; @@ -2856,11 +2892,7 @@ TEBCresume( fprintf(stdout, "%" SIZEd ": (%" SIZEd ") invoking ", iPtr->numLevels, PC_REL); } - Tcl_Size i; - for (i = 0; i < objc; i++) { - TclPrintObject(stdout, objv[i], 15); - fprintf(stdout, " "); - } + PrintArgumentWords(objc, objv); fprintf(stdout, "\n"); fflush(stdout); } @@ -4672,17 +4704,13 @@ TEBCresume( newDepth = i; #ifdef TCL_COMPILE_DEBUG if (tclTraceExec >= TCL_TRACE_BYTECODE_EXEC_COMMANDS) { - Tcl_Size j; if (traceInstructions) { strncpy(cmdNameBuf, TclGetString(objv[0]), 20); } else { fprintf(stdout, "%" SIZEd ": (%" SIZEd ") invoking ", iPtr->numLevels, PC_REL); } - for (j = 0; j < numArgs; j++) { - TclPrintObject(stdout, objv[j], 15); - fprintf(stdout, " "); - } + PrintArgumentWords(numArgs, objv); fprintf(stdout, "\n"); fflush(stdout); } @@ -4782,18 +4810,13 @@ TEBCresume( goto gotError; #ifdef TCL_COMPILE_DEBUG } else if (tclTraceExec >= TCL_TRACE_BYTECODE_EXEC_COMMANDS) { - Tcl_Size i; - if (traceInstructions) { strncpy(cmdNameBuf, TclGetString(objv[0]), 20); } else { fprintf(stdout, "%" SIZEd ": (%" SIZEu ") invoking ", iPtr->numLevels, PC_REL); } - for (i = 0; i < numArgs; i++) { - TclPrintObject(stdout, objv[i], 15); - fprintf(stdout, " "); - } + PrintArgumentWords(numArgs, objv); fprintf(stdout, "\n"); fflush(stdout); #endif /*TCL_COMPILE_DEBUG*/ @@ -4834,14 +4857,16 @@ TEBCresume( } { - Method *const mPtr = - contextPtr->callPtr->chain[newDepth].mPtr; + 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, numArgs, objv); + (Tcl_ObjectContext) contextPtr, (int)numArgs, objv); } - return ((Tcl_MethodCallProc2 *)(void *)(mPtr->typePtr->callProc))(mPtr->clientData, interp, + // Ugly indirect cast + Tcl_MethodCallProc2 *call2Proc = (Tcl_MethodCallProc2 *) + (void *)mPtr->typePtr->callProc; + return call2Proc(mPtr->clientData, interp, (Tcl_ObjectContext) contextPtr, numArgs, objv); } @@ -5319,7 +5344,7 @@ TEBCresume( 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; } @@ -6772,7 +6797,7 @@ 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 %" SIZEd ": %s\n", varIndex, O2S(Tcl_GetObjResult(interp)))); @@ -7682,12 +7707,15 @@ TEBCresume( #ifndef REMOVE_DEPRECATED_OPCODES case INST_INVOKE_STK1: numArgs = TclGetUInt1AtPtr(pc + 1); - TRACE(("%u => ... after call: ", (unsigned)numArgs)); + TRACE(("%u => ... after \"%.20s\": ", (unsigned)numArgs, cmdNameBuf)); break; #endif // REMOVE_DEPRECATED_OPCODES case INST_INVOKE_STK: numArgs = TclGetUInt4AtPtr(pc + 1); - TRACE(("%u => ... after call: ", (unsigned)numArgs)); + TRACE(("%u => ... after \"%.20s\": ", (unsigned)numArgs, cmdNameBuf)); + break; + case INST_INVOKE_EXPANDED: + TRACE((" => ... after \"%.20s\": ", cmdNameBuf)); break; case INST_EVAL_STK: /* @@ -9656,7 +9684,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; } } -- cgit v0.12 From 780e40c53840bbee20ee4f9b077d9128ccd12ab4 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 30 May 2025 08:28:08 +0000 Subject: Workaround for Clang being obnoxious --- generic/tclNamesp.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 0d5776e..e3b35fb 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -4769,14 +4769,14 @@ NamespaceWhichCmd( TclNewObj(resultPtr); switch (lookupType) { - case 0: /* -command */ + case 0:; /* -command */ Tcl_Command cmd = Tcl_GetCommandFromObj(interp, objv[objc-1]); if (cmd != NULL) { Tcl_GetCommandFullName(interp, cmd, resultPtr); } break; - case 1: /* -variable */ + case 1:; /* -variable */ Tcl_Var var = Tcl_FindNamespaceVar(interp, TclGetString(objv[objc-1]), NULL, /*flags*/ 0); -- cgit v0.12 From ddd949b958a726f7ca34b9a3373721813bb7fe5a Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 30 May 2025 13:35:28 +0000 Subject: Another switch that can be marked explicitly as exhaustive --- generic/tclExecute.c | 2 ++ 1 file changed, 2 insertions(+) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 903210c..a076524 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -4893,6 +4893,8 @@ TEBCresume( 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); -- cgit v0.12 From d8ceb92fcc78d3d2cffc8b0091134188d20711cb Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 30 May 2025 14:00:04 +0000 Subject: Minor refactor of some parts of TclOO code --- generic/tclDisassemble.c | 119 +++++++++++++---------------------------------- generic/tclExecute.c | 101 ++++++++++++---------------------------- generic/tclOO.c | 31 ++---------- generic/tclOOBasic.c | 26 ++--------- generic/tclOOCall.c | 23 +++++++++ generic/tclOOInt.h | 1 + 6 files changed, 96 insertions(+), 205 deletions(-) diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index c9b9761..86a16db 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -1353,9 +1353,12 @@ Tcl_DisassembleObjCmd( Tcl_Obj *codeObjPtr = NULL; Proc *procPtr = NULL; Tcl_HashEntry *hPtr; + Tcl_Obj *ooWhat; Object *oPtr; + Class *classPtr; ByteCode *codePtr; Method *methodPtr; + const char *bodyType; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "type ..."); @@ -1453,23 +1456,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; @@ -1483,30 +1480,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) { @@ -1518,23 +1494,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; @@ -1548,30 +1518,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) { @@ -1583,19 +1532,13 @@ Tcl_DisassembleObjCmd( * Look up the body of a class method. */ - oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]); - if (oPtr == NULL) { + classPtr = TclOOGetClassFromObj(interp, objv[2]); + if (classPtr == 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); - return TCL_ERROR; - } - hPtr = Tcl_FindHashEntry(&oPtr->classPtr->classMethods, - objv[3]); + oPtr = classPtr->thisPtr; + ooWhat = objv[3]; + hPtr = Tcl_FindHashEntry(&classPtr->classMethods, ooWhat); goto methodBody; case DISAS_OBJECT_METHOD: if (objc != 4) { @@ -1614,7 +1557,8 @@ Tcl_DisassembleObjCmd( if (oPtr->methodsPtr == NULL) { goto unknownMethod; } - hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, objv[3]); + ooWhat = objv[3]; + hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, ooWhat); /* * Compile (if necessary) and disassemble a method body. @@ -1624,9 +1568,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)); @@ -1637,6 +1581,9 @@ Tcl_DisassembleObjCmd( "METHODTYPE", (char *)NULL); return TCL_ERROR; } + bodyType = "body of method"; + + compileMethodIfNeeded: if (!TclHasInternalRep(procPtr->bodyPtr, &tclByteCodeType)) { Command cmd; @@ -1648,8 +1595,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; diff --git a/generic/tclExecute.c b/generic/tclExecute.c index b3e5b22..6448fda 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -4655,6 +4655,7 @@ TEBCresume( { Object *oPtr; + Class *classPtr; CallFrame *framePtr; CallContext *contextPtr; Tcl_Size skip, newDepth; @@ -4713,79 +4714,44 @@ TEBCresume( } contextPtr = (CallContext *)framePtr->clientData; - oPtr = (Object *) Tcl_GetObjectFromObj(interp, valuePtr); - if (oPtr == NULL) { - TRACE_APPEND(("ERROR: \"%.30s\" not object\n", O2S(valuePtr))); + DECACHE_STACK_INFO(); + classPtr = TclOOGetClassFromObj(interp, valuePtr); + CACHE_STACK_INFO(); + if (classPtr == NULL) { + TRACE_APPEND(("ERROR: \"%.30s\" not class\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 ; icallPtr->numChain ; i++) { - miPtr = contextPtr->callPtr->chain + i; + MInvoke *miPtr = contextPtr->callPtr->chain + i; if (!miPtr->isFilter && miPtr->mPtr->declaringClassPtr == classPtr) { newDepth = i; -#ifdef TCL_COMPILE_DEBUG - if (tclTraceExec >= TCL_TRACE_BYTECODE_EXEC_COMMANDS) { - Tcl_Size j; - if (traceInstructions) { - strncpy(cmdNameBuf, TclGetString(objv[0]), 20); - } else { - fprintf(stdout, "%" SIZEd ": (%" SIZEd ") invoking ", - iPtr->numLevels, PC_REL); - } - for (j = 0; j < numArgs; j++) { - TclPrintObject(stdout, objv[j], 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"; - } + // Unlikely; cold path 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; + MInvoke *miPtr = contextPtr->callPtr->chain + i; + if (!miPtr->isFilter + && miPtr->mPtr->declaringClassPtr == classPtr) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s implementation by \"%s\" not reachable from here", + TclOOContextTypeName(contextPtr), + TclGetString(valuePtr))); + DECACHE_STACK_INFO(); + OO_ERROR(interp, CLASS_NOT_REACHABLE); + CACHE_STACK_INFO(); + goto gotError; } - 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))); + TclOOContextTypeName(contextPtr), TclGetString(valuePtr))); DECACHE_STACK_INFO(); OO_ERROR(interp, CLASS_NOT_THERE); CACHE_STACK_INFO(); @@ -4831,31 +4797,24 @@ TEBCresume( * equivalent) unexpectedly. */ - 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)); + "no next %s implementation", TclOOContextTypeName(contextPtr))); DECACHE_STACK_INFO(); OO_ERROR(interp, NOTHING_NEXT); CACHE_STACK_INFO(); goto gotError; + } + + doInvokeNext: #ifdef TCL_COMPILE_DEBUG - } else if (tclTraceExec >= TCL_TRACE_BYTECODE_EXEC_COMMANDS) { + if (tclTraceExec >= TCL_TRACE_BYTECODE_EXEC_COMMANDS) { Tcl_Size i; if (traceInstructions) { strncpy(cmdNameBuf, TclGetString(objv[0]), 20); } else { - fprintf(stdout, "%" SIZEd ": (%" SIZEu ") invoking ", + fprintf(stdout, "%" SIZEd ": (%" SIZEd ") invoking ", iPtr->numLevels, PC_REL); } for (i = 0; i < numArgs; i++) { @@ -4864,10 +4823,8 @@ TEBCresume( } fprintf(stdout, "\n"); fflush(stdout); -#endif /*TCL_COMPILE_DEBUG*/ } - - doInvokeNext: +#endif /*TCL_COMPILE_DEBUG*/ bcFramePtr->data.tebc.pc = (char *) pc; iPtr->cmdFramePtr = bcFramePtr; @@ -4914,14 +4871,18 @@ TEBCresume( } case INST_TCLOO_IS_OBJECT: + DECACHE_STACK_INFO(); oPtr = (Object *) Tcl_GetObjectFromObj(interp, OBJ_AT_TOS); + CACHE_STACK_INFO(); objResultPtr = TCONST(oPtr != NULL ? 1 : 0); TRACE_WITH_OBJ(("%.30s => ", O2S(OBJ_AT_TOS)), objResultPtr); NEXT_INST_F(1, 1, 1); case INST_TCLOO_CLASS: 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))); goto gotError; diff --git a/generic/tclOO.c b/generic/tclOO.c index 8ac5494..c637af1 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -2885,7 +2885,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) { /* @@ -2895,22 +2894,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; } @@ -2932,8 +2920,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 @@ -2964,22 +2952,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; } diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index 36b9e9c..490fe38 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -958,11 +958,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 @@ -977,7 +972,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. @@ -987,15 +982,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; } @@ -1005,6 +993,7 @@ TclOONextToObjCmd( * allow jumping backwards! */ + Tcl_Size i; for (i=contextPtr->index+1 ; icallPtr->numChain ; i++) { MInvoke *miPtr = &contextPtr->callPtr->chain[i]; @@ -1028,14 +1017,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]; diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index fe44bed..62de24c 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. diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index 2607df6..913e6db 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -567,6 +567,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); -- cgit v0.12 From 14c5e416e3a4e253b45781af6480fcbe36e70398 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 30 May 2025 18:55:57 +0000 Subject: [fa7995bdf2] Stop crash in [http::cookiejar create]. --- generic/tclCompCmds.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 2773188..0d9989a 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -2122,7 +2122,7 @@ TclCompileDictWithCmd( */ if (!TclIsEmptyToken(tokenPtr)) { - if (!EnvHasLVT(envPtr)) { + if (envPtr->procPtr == NULL) { return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr); } -- cgit v0.12 From 8e0716b08266195c8b07aab0deb37f310fa35057 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 30 May 2025 19:35:52 +0000 Subject: [9a4876e887] Get ooWhat initialized before any error handling paths. --- generic/tclDisassemble.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index d44062c..6fecec0 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -1532,12 +1532,12 @@ Tcl_DisassembleObjCmd( * Look up the body of a class method. */ + ooWhat = objv[3]; classPtr = TclOOGetClassFromObj(interp, objv[2]); if (classPtr == NULL) { return TCL_ERROR; } oPtr = classPtr->thisPtr; - ooWhat = objv[3]; hPtr = Tcl_FindHashEntry(&classPtr->classMethods, ooWhat); goto methodBody; case DISAS_OBJECT_METHOD: @@ -1550,6 +1550,7 @@ 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; @@ -1557,7 +1558,6 @@ Tcl_DisassembleObjCmd( if (oPtr->methodsPtr == NULL) { goto unknownMethod; } - ooWhat = objv[3]; hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, ooWhat); /* -- cgit v0.12 From 3f8091f15a352bfdb1e0c78522aee97d5fbadba2 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 31 May 2025 08:13:16 +0000 Subject: Should set variable earlier --- generic/tclDisassemble.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index 026326f..5070c3f 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -1568,10 +1568,10 @@ Tcl_DisassembleObjCmd( if (oPtr == NULL) { return TCL_ERROR; } + ooWhat = objv[3]; if (oPtr->methodsPtr == NULL) { goto unknownMethod; } - ooWhat = objv[3]; hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, ooWhat); /* -- cgit v0.12 From 923be72f83a25825a5acca2871074d7fbe8327cb Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sun, 1 Jun 2025 18:13:01 +0000 Subject: Cherrypick 57d619a23f - Jan's changes for unused vars --- win/tclWinInit.c | 55 +++---------------------------------------------------- 1 file changed, 3 insertions(+), 52 deletions(-) diff --git a/win/tclWinInit.c b/win/tclWinInit.c index 23aad3e..b3ea057 100644 --- a/win/tclWinInit.c +++ b/win/tclWinInit.c @@ -36,12 +36,6 @@ typedef struct { WORD wReserved; } OemId; -typedef struct { - Tcl_Encoding userEncoding; -} ThreadSpecificData; - -static Tcl_ThreadDataKey dataKey; - /* * The following arrays contain the human readable strings for the * processor values. @@ -154,9 +148,9 @@ TclpGetCodePageOnce( * - added bonus, RegGetValue is much more convenient to use */ if (RegGetValueA(HKEY_LOCAL_MACHINE, - "SYSTEM\\CurrentControlSet\\Control\\Nls\\CodePage", - "ACP", RRF_RT_REG_SZ, NULL, codePage+2, - &size) != ERROR_SUCCESS) { + "SYSTEM\\CurrentControlSet\\Control\\Nls\\CodePage", + "ACP", RRF_RT_REG_SZ, NULL, codePage+2, + &size) != ERROR_SUCCESS) { /* On failure, fallback to GetACP() */ UINT acp = GetACP(); snprintf(codePage, sizeof(codePage), "cp%u", acp); @@ -530,49 +524,6 @@ TclpSetInitialEncodings(void) Tcl_DStringFree(&encodingName); } -#if 0 - -/* - *--------------------------------------------------------------------------- - * - * TclpGetEncodingForUser -- - * - * Returns the Tcl_Encoding corresponding to the user code page. - * - * Results: - * A Tcl_Encoding value or NULL if the encoding cannot be found or - * if Tcl does not support the encoding. - * - * Side effects: - * The encoding is cached in the thread local storage. - *--------------------------------------------------------------------------- - */ -Tcl_Encoding -TclpGetEncodingForUser(Tcl_Interp *interp) -{ - /* - * In keeping with Windows, the encoding will not be updated if the - * registry value changes so we never need to update it once - * successfully retrieved. - */ - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - if (tsdPtr->userEncoding == NULL) { - tsdPtr->userEncoding = - Tcl_GetEncoding(interp, TclpGetCodePage()); - } - return tsdPtr->userEncoding; -} - -void TclpReleaseEncodingForUser(void) -{ - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - if (tsdPtr->userEncoding) { - Tcl_FreeEncoding(tsdPtr->userEncoding); - tsdPtr->userEncoding = NULL; - } -} -#endif - const char * Tcl_GetEncodingNameForUser(Tcl_DString *bufPtr) { -- cgit v0.12 From 3f43b4f84ea1d0210b3905542f31f20fbdbffd09 Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 2 Jun 2025 08:52:39 +0000 Subject: Use correct variable name... --- generic/tclOOProp.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclOOProp.c b/generic/tclOOProp.c index 1ef7dd8..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", -- cgit v0.12 From 810f50427cac60c40f4f72049489410008dc666a Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 2 Jun 2025 11:42:02 +0000 Subject: Ensure we never concatenate too many values at once --- generic/tclCompCmdsGR.c | 31 ++++++++++++++++++++++++------- 1 file changed, 24 insertions(+), 7 deletions(-) diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index d8fc4ad..f983505 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -27,6 +27,9 @@ static void CompileReturnInternal(CompileEnv *envPtr, Tcl_Obj *returnOpts); static Tcl_LVTIndex IndexTailVarIfKnown(Tcl_Interp *interp, Tcl_Token *varTokenPtr, CompileEnv *envPtr); + +// Maximum number of items to concatenate in one go. +#define MAX_LIST_CONCAT 0x7FFFFFFE /* *---------------------------------------------------------------------- @@ -902,11 +905,10 @@ TclCompileLappendCmd( if (numWords == 2) { PUSH( ""); } else { - Tcl_Size build; - int concat; + Tcl_Size build = 0; + int concat = 0; valueTokenPtr = TokenAfter(varTokenPtr); - concat = build = 0; for (i = 2; i < numWords; i++) { if (valueTokenPtr->type == TCL_TOKEN_EXPAND_WORD && build > 0) { OP4( LIST, build); @@ -926,6 +928,14 @@ TclCompileLappendCmd( } else { build++; } + if (build > MAX_LIST_CONCAT) { + OP4( LIST, build); + if (concat) { + OP( LIST_CONCAT); + } + build = 0; + concat = 1; + } valueTokenPtr = TokenAfter(valueTokenPtr); } if (build > 0) { @@ -1179,8 +1189,8 @@ TclCompileListCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *valueTokenPtr; - Tcl_Size i, numWords = parsePtr->numWords; - int concat, build; + Tcl_Size i, build, numWords = parsePtr->numWords; + int concat; Tcl_Obj *listObj, *objPtr; if (numWords > UINT_MAX) { @@ -1223,8 +1233,7 @@ TclCompileListCmd( */ 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) { OP4( LIST, build); if (concat) { @@ -1243,6 +1252,14 @@ TclCompileListCmd( } else { build++; } + if (build > MAX_LIST_CONCAT) { + OP4( LIST, build); + if (concat) { + OP( LIST_CONCAT); + } + build = 0; + concat = 1; + } valueTokenPtr = TokenAfter(valueTokenPtr); } if (build > 0) { -- cgit v0.12 From 56ec7b2901a5eb8c2d48aba65eee5eb82640b152 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 2 Jun 2025 14:18:14 +0000 Subject: Backport: Add [[unreachable]] and [[fallthrough]] from C23 (where available) --- generic/tclBasic.c | 7 +++-- generic/tclBinary.c | 60 ++++++++++++++++++++++----------------- generic/tclClock.c | 15 ++++++++-- generic/tclClockFmt.c | 71 ++++++++++++++++++++++++++++------------------- generic/tclCmdAH.c | 6 ++-- generic/tclCmdMZ.c | 17 ++++++++++-- generic/tclCompCmdsGR.c | 1 + generic/tclCompCmdsSZ.c | 2 +- generic/tclCompile.c | 9 +++++- generic/tclConfig.c | 3 +- generic/tclDate.h | 2 +- generic/tclDictObj.c | 27 +++++++++--------- generic/tclEncoding.c | 6 ++-- generic/tclEnsemble.c | 9 ++++-- generic/tclEvent.c | 4 ++- generic/tclFileName.c | 2 ++ generic/tclIOCmd.c | 8 ++++-- generic/tclIORChan.c | 2 ++ generic/tclIcu.c | 13 ++++++--- generic/tclInt.h | 26 +++++++++++++++++ generic/tclInterp.c | 21 ++++++++++---- generic/tclLink.c | 2 +- generic/tclLoad.c | 7 +++-- generic/tclNamesp.c | 8 +++--- generic/tclOOBasic.c | 27 ++++-------------- generic/tclOOCall.c | 6 ++-- generic/tclOODefineCmds.c | 6 ++-- generic/tclOOInfo.c | 14 ++++++++-- generic/tclOOProp.c | 6 ++++ generic/tclParse.c | 11 ++++++-- generic/tclPathObj.c | 5 +--- generic/tclPkg.c | 22 ++++++--------- generic/tclProc.c | 6 ++-- generic/tclProcess.c | 3 +- generic/tclScan.c | 14 ++++------ generic/tclStrIdxTree.c | 8 ++++-- generic/tclStrToD.c | 53 ++++++++++++++++++++++------------- generic/tclStringObj.c | 20 +++++++------ generic/tclTest.c | 2 +- generic/tclTimer.c | 2 +- generic/tclTrace.c | 16 +++++++++-- generic/tclUtil.c | 6 ++-- generic/tclVar.c | 8 ++++-- generic/tclZipfs.c | 2 ++ generic/tclZlib.c | 35 ++++++++++++++--------- unix/tclUnixChan.c | 12 ++++---- win/tclWinPipe.c | 2 +- 47 files changed, 386 insertions(+), 228 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 6c73ed0..94d464f 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4620,7 +4620,8 @@ Dispatch( } if (TCL_DTRACE_CMD_INFO_ENABLED() && iPtr->cmdFramePtr) { Tcl_Obj *info = TclInfoFrame(interp, iPtr->cmdFramePtr); - const char *a[6]; Tcl_Size i[2]; + const char *a[6]; + Tcl_Size i[2]; TclDTraceInfo(info, a, i); TCL_DTRACE_CMD_INFO(a[0], a[1], a[2], a[3], i[0], i[1], a[4], a[5]); @@ -6548,7 +6549,7 @@ Tcl_ExprLongObj( } resultPtr = Tcl_NewBignumObj(&big); } - /* FALLTHRU */ + TCL_FALLTHROUGH(); case TCL_NUMBER_INT: case TCL_NUMBER_BIG: result = TclGetLongFromObj(interp, resultPtr, ptr); @@ -9616,7 +9617,7 @@ TclNRInterpCoroutine( Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", (char *)NULL); return TCL_ERROR; } - /* fallthrough */ + TCL_FALLTHROUGH(); case COROUTINE_ARGUMENTS_ARBITRARY: if (objc > 1) { Tcl_SetObjResult(interp, Tcl_NewListObj(objc - 1, objv + 1)); diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 675f250..5094a88 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -2505,6 +2505,8 @@ BinaryDecodeHex( case OPT_STRICT: strict = 1; break; + default: + TCL_UNREACHABLE(); } } @@ -2649,6 +2651,8 @@ BinaryEncode64( wrapchar = TclGetStringFromObj(objv[i + 1], &wrapcharlen); } break; + default: + TCL_UNREACHABLE(); } } if (wrapcharlen == 0) { @@ -2773,36 +2777,36 @@ BinaryEncodeUu( case OPT_WRAPCHAR: wrapchar = (const unsigned char *)TclGetStringFromObj( objv[i + 1], &wrapcharlen); - { - const unsigned char *p = wrapchar; - Tcl_Size numBytes = wrapcharlen; - - while (numBytes) { - switch (*p) { - case '\t': - case '\v': - case '\f': - case '\r': - p++; numBytes--; - continue; - case '\n': - numBytes--; - break; - default: - badwrap: - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "invalid wrapchar; will defeat decoding", - -1)); - Tcl_SetErrorCode(interp, "TCL", "BINARY", - "ENCODE", "WRAPCHAR", (char *)NULL); - return TCL_ERROR; - } - } - if (numBytes) { + const unsigned char *p = wrapchar; + Tcl_Size numBytes = wrapcharlen; + + while (numBytes) { + switch (*p) { + case '\t': + case '\v': + case '\f': + case '\r': + p++; + numBytes--; + continue; + case '\n': + numBytes--; + break; + default: goto badwrap; } } + if (numBytes) { + badwrap: + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "invalid wrapchar; will defeat decoding", -1)); + Tcl_SetErrorCode(interp, "TCL", "BINARY", + "ENCODE", "WRAPCHAR", (char *)NULL); + return TCL_ERROR; + } break; + default: + TCL_UNREACHABLE(); } } @@ -2909,6 +2913,8 @@ BinaryDecodeUu( case OPT_STRICT: strict = 1; break; + default: + TCL_UNREACHABLE(); } } @@ -3084,6 +3090,8 @@ BinaryDecode64( case OPT_STRICT: strict = 1; break; + default: + TCL_UNREACHABLE(); } } diff --git a/generic/tclClock.c b/generic/tclClock.c index d4edec4..a850058 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -1154,6 +1154,8 @@ ClockConfigureObjCmd( } break; } + default: + TCL_UNREACHABLE(); } } @@ -3159,6 +3161,8 @@ ClockClicksObjCmd( case CLICKS_MICROS: clicks = TclpGetMicroseconds(); break; + default: + TCL_UNREACHABLE(); } Tcl_SetObjResult(interp, Tcl_NewWideIntObj(clicks)); @@ -3371,6 +3375,8 @@ ClockParseFmtScnArgs( } } break; + default: + TCL_UNREACHABLE(); } saw |= 1 << optionIndex; } @@ -3431,8 +3437,8 @@ ClockParseFmtScnArgs( } Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad seconds \"%s\": must be now or integer", - TclGetString(baseObj))); + "bad seconds \"%s\": must be now or integer", + TclGetString(baseObj))); i = baseIdx; goto badOption; } @@ -3624,7 +3630,8 @@ ClockScanObjCmd( } /* seconds are in localSeconds (relative base date), so reset time here */ - yyHour = yyMinutes = yySeconds = yySecondOfDay = 0; yyMeridian = MER24; + yyHour = yyMinutes = yySeconds = yySecondOfDay = 0; + yyMeridian = MER24; /* If free scan */ if (opts.formatObj == NULL) { @@ -4537,6 +4544,8 @@ ClockAddObjCmd( case CLC_ADD_SECONDS: yyRelSeconds += offs; break; + default: + TCL_UNREACHABLE(); } if (unitIndex < CLC_ADD_HOURS) { /* date units only */ info->flags |= CLF_RELCONV; diff --git a/generic/tclClockFmt.c b/generic/tclClockFmt.c index 358c4f0..7819ee5 100644 --- a/generic/tclClockFmt.c +++ b/generic/tclClockFmt.c @@ -565,7 +565,10 @@ ClockFmtScnStorageAllocProc( allocsize -= sizeof(hPtr->key); } - fss = (ClockFmtScnStorage *)Tcl_Alloc(allocsize); + fss = (ClockFmtScnStorage *)Tcl_AttemptAlloc(allocsize); + if (!fss) { + return NULL; + } /* initialize */ memset(fss, 0, sizeof(*fss)); @@ -1024,7 +1027,7 @@ static const char * FindTokenBegin( const char *p, const char *end, - ClockScanToken *tok, + const ClockScanToken *tok, int flags) { if (p < end) { @@ -1037,10 +1040,14 @@ FindTokenBegin( if (!(flags & CLF_STRICT)) { /* should match at least one digit or space */ while (!isdigit(UCHAR(*p)) && !isspace(UCHAR(*p)) && - (p = Tcl_UtfNext(p)) < end) {} + (p = Tcl_UtfNext(p)) < end) { + // Empty + } } else { /* should match at least one digit */ - while (!isdigit(UCHAR(*p)) && (p = Tcl_UtfNext(p)) < end) {} + while (!isdigit(UCHAR(*p)) && (p = Tcl_UtfNext(p)) < end) { + // Empty + } } return p; @@ -1049,19 +1056,25 @@ FindTokenBegin( goto findChar; case CTOKT_SPACE: - while (!isspace(UCHAR(*p)) && (p = Tcl_UtfNext(p)) < end) {} + while (!isspace(UCHAR(*p)) && (p = Tcl_UtfNext(p)) < end) { + // Empty + } return p; case CTOKT_CHAR: c = *((char *)tok->map->data); -findChar: + findChar: if (!(flags & CLF_STRICT)) { /* should match the char or space */ while (*p != c && !isspace(UCHAR(*p)) && - (p = Tcl_UtfNext(p)) < end) {} + (p = Tcl_UtfNext(p)) < end) { + // Empty + } } else { /* should match the char */ - while (*p != c && (p = Tcl_UtfNext(p)) < end) {} + while (*p != c && (p = Tcl_UtfNext(p)) < end) { + // Empty + } } return p; } @@ -1089,7 +1102,7 @@ static void DetermineGreedySearchLen( ClockFmtScnCmdArgs *opts, DateInfo *info, - ClockScanToken *tok, + const ClockScanToken *tok, int *minLenPtr, int *maxLenPtr) { @@ -1141,7 +1154,7 @@ DetermineGreedySearchLen( /* try to get max length more precise for greedy match, * check the next ahead token available there */ if (minLen < maxLen && tok->lookAhTok) { - ClockScanToken *laTok = tok + tok->lookAhTok + 1; + const ClockScanToken *laTok = tok + tok->lookAhTok + 1; p = yyInput + maxLen; /* regards all possible spaces here (because they are optional) */ @@ -1155,7 +1168,7 @@ DetermineGreedySearchLen( /* try to find laTok between [lookAhMin, lookAhMax] */ while (minLen < maxLen) { const char *f = FindTokenBegin(p, end, laTok, - TCL_CLOCK_FULL_COMPAT ? opts->flags : CLF_STRICT); + TCL_CLOCK_FULL_COMPAT ? opts->flags : CLF_STRICT); /* if found (not below lookAhMax) */ if (f < end) { break; @@ -1491,7 +1504,7 @@ StaticListSearch( static inline const char * FindWordEnd( - ClockScanToken *tok, + const ClockScanToken *tok, const char *p, const char *end) { @@ -1516,7 +1529,7 @@ static int ClockScnToken_Month_Proc( ClockFmtScnCmdArgs *opts, DateInfo *info, - ClockScanToken *tok) + const ClockScanToken *tok) { #if 0 /* currently unused, test purposes only */ @@ -1566,7 +1579,7 @@ static int ClockScnToken_DayOfWeek_Proc( ClockFmtScnCmdArgs *opts, DateInfo *info, - ClockScanToken *tok) + const ClockScanToken *tok) { static int dowKeys[] = {MCLIT_DAYS_OF_WEEK_ABBREV, MCLIT_DAYS_OF_WEEK_FULL, 0}; @@ -1640,7 +1653,7 @@ static int ClockScnToken_amPmInd_Proc( ClockFmtScnCmdArgs *opts, DateInfo *info, - ClockScanToken *tok) + const ClockScanToken *tok) { int ret, val; int minLen, maxLen; @@ -1673,7 +1686,7 @@ static int ClockScnToken_LocaleERA_Proc( ClockFmtScnCmdArgs *opts, DateInfo *info, - ClockScanToken *tok) + const ClockScanToken *tok) { ClockClientData *dataPtr = opts->dataPtr; @@ -1712,7 +1725,7 @@ static int ClockScnToken_LocaleListMatcher_Proc( ClockFmtScnCmdArgs *opts, DateInfo *info, - ClockScanToken *tok) + const ClockScanToken *tok) { int ret, val; int minLen, maxLen; @@ -1743,7 +1756,7 @@ static int ClockScnToken_JDN_Proc( ClockFmtScnCmdArgs *opts, DateInfo *info, - ClockScanToken *tok) + const ClockScanToken *tok) { int minLen, maxLen; const char *p = yyInput, *end, *s; @@ -1814,7 +1827,7 @@ static int ClockScnToken_TimeZone_Proc( ClockFmtScnCmdArgs *opts, DateInfo *info, - ClockScanToken *tok) + const ClockScanToken *tok) { int minLen, maxLen; int len = 0; @@ -1906,7 +1919,7 @@ static int ClockScnToken_StarDate_Proc( ClockFmtScnCmdArgs *opts, DateInfo *info, - ClockScanToken *tok) + const ClockScanToken *tok) { int minLen, maxLen; const char *p = yyInput, *end, *s; @@ -2300,8 +2313,7 @@ ClockGetOrParseScanFormat( tokCnt++; continue; } - word_tok: - { + word_tok: { /* try continue with previous word token */ ClockScanToken *wordTok = tok - 1; @@ -2324,9 +2336,9 @@ ClockGetOrParseScanFormat( AllocTokenInChain(tok, scnTok, fss->scnTokC, ClockScanToken *); tokCnt++; } - } break; } + } } /* calculate end distance value for each tokens */ @@ -2373,8 +2385,8 @@ ClockScan( ClockFmtScnCmdArgs *opts) /* Command options */ { ClockClientData *dataPtr = opts->dataPtr; - ClockFmtScnStorage *fss; - ClockScanToken *tok; + const ClockFmtScnStorage *fss; + const ClockScanToken *tok; const ClockScanTokenMap *map; const char *p, *x, *end; unsigned short flags = 0; @@ -2554,6 +2566,8 @@ ClockScan( } p++; break; + default: + TCL_UNREACHABLE(); } } /* check end was reached */ @@ -2602,7 +2616,7 @@ ClockScan( case (CLF_DAYOFYEAR | CLF_DAYOFMONTH): /* miss month: ddd over dd (without month) */ flags &= ~CLF_DAYOFMONTH; - /* fallthrough */ + TCL_FALLTHROUGH(); case CLF_DAYOFYEAR: /* ddd over naked weekday */ if (!(flags & CLF_ISO8601YEAR)) { @@ -3343,8 +3357,7 @@ ClockGetOrParseFmtFormat( continue; } default: - word_tok: - { + word_tok: { /* try continue with previous word token */ ClockFormatToken *wordTok = tok - 1; @@ -3363,9 +3376,9 @@ ClockGetOrParseFmtFormat( AllocTokenInChain(tok, fmtTok, fss->fmtTokC, ClockFormatToken *); tokCnt++; } - } break; } + } } /* correct count of real used tokens and free mem if desired diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 877b3bb..673b4f8 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -485,6 +485,8 @@ EncodingConvertParseOptions( case FAILINDEX: failVarObj = objv[argIndex]; break; + default: + TCL_UNREACHABLE(); } } /* Get encoding after opts so no need to free it on option error */ @@ -2152,8 +2154,7 @@ PathTypeCmd( TclNewLiteralStringObj(typeName, "volumerelative"); break; default: - /* Should be unreachable */ - return TCL_OK; + TCL_UNREACHABLE(); } Tcl_SetObjResult(interp, typeName); return TCL_OK; @@ -2962,6 +2963,7 @@ ForeachLoopStep( "\n (\"%s\" body line %d)", (statePtr->resultList != NULL ? "lmap" : "foreach"), Tcl_GetErrorLine(interp))); + TCL_FALLTHROUGH(); default: goto done; } diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index fb04232..22329fe 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -211,6 +211,8 @@ Tcl_RegexpObjCmd( case REGEXP_LAST: i++; goto endOfForLoop; + default: + TCL_UNREACHABLE(); } } @@ -566,6 +568,8 @@ Tcl_RegsubObjCmd( case REGSUB_LAST: idx++; goto endOfForLoop; + default: + TCL_UNREACHABLE(); } } @@ -1580,6 +1584,8 @@ StringIsCmd( } failVarObj = objv[++i]; break; + default: + TCL_UNREACHABLE(); } } } @@ -1877,6 +1883,8 @@ StringIsCmd( case STR_IS_XDIGIT: chcomp = UniCharIsHexDigit; break; + default: + TCL_UNREACHABLE(); } if (chcomp != NULL) { @@ -4186,6 +4194,8 @@ Tcl_TimeRateObjCmd( break; case TMRT_LAST: break; + default: + TCL_UNREACHABLE(); } } @@ -4410,7 +4420,7 @@ Tcl_TimeRateObjCmd( */ threshold = 1; maxcnt = 0; - /* FALLTHRU */ + TCL_FALLTHROUGH(); case TCL_CONTINUE: result = TCL_OK; break; @@ -4499,7 +4509,8 @@ Tcl_TimeRateObjCmd( lastIterTm = avgIterTm; } estIterTm *= lastIterTm; - last = middle; lastCount = count; + last = middle; + lastCount = count; /* * Calculate next threshold to check. @@ -4836,6 +4847,8 @@ TclNRTryObjCmd( haveHandlers = 1; i += 3; break; + default: + TCL_UNREACHABLE(); } } if (bodyShared) { diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 45befc7..c373018 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -2201,6 +2201,7 @@ TclCompileRegsubCmd( * but we definitely can't handle that at all. */ } + TCL_FALLTHROUGH(); case '\0': case '?': case '[': case '\\': goto done; } diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 38fd8d6..5e27796 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -2221,7 +2221,7 @@ IssueSwitchChainedTests( } break; default: - Tcl_Panic("unknown switch mode: %d", mode); + TCL_UNREACHABLE(); } /* diff --git a/generic/tclCompile.c b/generic/tclCompile.c index a0ddd08..beb716c 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1208,12 +1208,18 @@ IsCompactibleCompileEnv( case INST_EVAL_STK: case INST_EXPR_STK: case INST_YIELD: + case INST_YIELD_TO_INVOKE: return 0; /* Upvars */ case INST_UPVAR: case INST_NSUPVAR: case INST_VARIABLE: return 0; + /* TclOO::next is NOT a problem: puts stack frame out of way. + * There's a way to do it, but it's beneath the threshold of + * likelihood. */ + case INST_TCLOO_NEXT: + case INST_TCLOO_NEXT_CLASS: default: size = tclInstructionTable[*pc].numBytes; assert (size > 0); @@ -3485,7 +3491,8 @@ TclGetInnermostExceptionRange( ExceptionRange *rangePtr = envPtr->exceptArrayPtr + i; while (i > 0) { - rangePtr--; i--; + rangePtr--; + i--; if (CurrentOffset(envPtr) >= (int)rangePtr->codeOffset && (rangePtr->numCodeBytes == TCL_INDEX_NONE || CurrentOffset(envPtr) < diff --git a/generic/tclConfig.c b/generic/tclConfig.c index a297545..7a7ce37 100644 --- a/generic/tclConfig.c +++ b/generic/tclConfig.c @@ -299,8 +299,7 @@ QueryConfigObjCmd( return TCL_OK; default: - Tcl_Panic("QueryConfigObjCmd: Unknown subcommand to 'pkgconfig'. This can't happen"); - break; + TCL_UNREACHABLE(); } return TCL_ERROR; } diff --git a/generic/tclDate.h b/generic/tclDate.h index a63eb0e..366ae59 100644 --- a/generic/tclDate.h +++ b/generic/tclDate.h @@ -393,7 +393,7 @@ typedef struct ClockScanToken ClockScanToken; typedef int ClockScanTokenProc( ClockFmtScnCmdArgs *opts, DateInfo *info, - ClockScanToken *tok); + const ClockScanToken *tok); typedef enum _CLCKTOK_TYPE { CTOKT_INT = 1, CTOKT_WIDE, CTOKT_PARSER, CTOKT_SPACE, CTOKT_WORD, CTOKT_CHAR, diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 6216430..505e2b2 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -3421,7 +3421,7 @@ DictFilterCmd( Tcl_ResetResult(interp); Tcl_DictObjDone(&search); - /* FALLTHRU */ + TCL_FALLTHROUGH(); case TCL_CONTINUE: result = TCL_OK; break; @@ -3429,6 +3429,7 @@ DictFilterCmd( Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (\"dict filter\" script line %d)", Tcl_GetErrorLine(interp))); + TCL_FALLTHROUGH(); default: goto abnormalResult; } @@ -3454,20 +3455,18 @@ DictFilterCmd( TclDecrRefCount(resultObj); } return result; - - abnormalResult: - Tcl_DictObjDone(&search); - TclDecrRefCount(keyObj); - TclDecrRefCount(valueObj); - TclDecrRefCount(keyVarObj); - TclDecrRefCount(valueVarObj); - TclDecrRefCount(scriptObj); - TclDecrRefCount(resultObj); - return result; } - Tcl_Panic("unexpected fallthrough"); - /* Control never reaches this point. */ - return TCL_ERROR; + TCL_UNREACHABLE(); + + abnormalResult: + Tcl_DictObjDone(&search); + TclDecrRefCount(keyObj); + TclDecrRefCount(valueObj); + TclDecrRefCount(keyVarObj); + TclDecrRefCount(valueVarObj); + TclDecrRefCount(scriptObj); + TclDecrRefCount(resultObj); + return result; } /* diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 3f26ab7..ce5fda4 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -2584,7 +2584,8 @@ UtfToUtfProc( } else { /* TCL_ENCODING_PROFILE_TCL8 */ char chbuf[2]; - chbuf[0] = UCHAR(*src++); chbuf[1] = 0; + chbuf[0] = UCHAR(*src++); + chbuf[1] = 0; TclUtfToUniChar(chbuf, &ch); } dst += Tcl_UniCharToUtf(ch, dst); @@ -3510,7 +3511,8 @@ TableToUtfProc( ch = UNICODE_REPLACE_CHAR; } else { char chbuf[2]; - chbuf[0] = byte; chbuf[1] = 0; + chbuf[0] = byte; + chbuf[1] = 0; TclUtfToUniChar(chbuf, &ch); } } diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index a11f382..cf4e18f 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -230,9 +230,8 @@ TclNamespaceEnsembleCmd( } default: - Tcl_Panic("unexpected ensemble command"); + TCL_UNREACHABLE(); } - return TCL_OK; } /* @@ -387,6 +386,8 @@ InitEnsembleFromOptions( } unknownObj = (len > 0 ? objv[1] : NULL); continue; + default: + TCL_UNREACHABLE(); } } @@ -485,6 +486,8 @@ ReadOneEnsembleOption( Tcl_SetObjResult(interp, resultObj); } break; + default: + TCL_UNREACHABLE(); } return TCL_OK; } @@ -715,6 +718,8 @@ SetEnsembleConfigOptions( } unknownObj = (len > 0 ? objv[1] : NULL); continue; + default: + TCL_UNREACHABLE(); } } diff --git a/generic/tclEvent.c b/generic/tclEvent.c index 4dd10d8..d991d66 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -1650,6 +1650,8 @@ Tcl_VwaitObjCmd( vwaitItems[numItems].sourceObj = objv[i]; numItems++; break; + default: + TCL_UNREACHABLE(); } } @@ -1967,7 +1969,7 @@ Tcl_UpdateObjCmd( flags = TCL_IDLE_EVENTS|TCL_DONT_WAIT; break; default: - Tcl_Panic("Tcl_UpdateObjCmd: bad option index to UpdateOptions"); + TCL_UNREACHABLE(); } } else { Tcl_WrongNumArgs(interp, 1, objv, "?idletasks?"); diff --git a/generic/tclFileName.c b/generic/tclFileName.c index 068a041..693018b 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -1233,6 +1233,8 @@ Tcl_GlobObjCmd( case GLOB_LAST: /* -- */ i++; goto endOfForLoop; + default: + TCL_UNREACHABLE(); } } diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index aefefee..485812f 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -135,7 +135,7 @@ Tcl_PutsObjCmd( string = objv[3]; break; } - /* Fall through */ + TCL_FALLTHROUGH(); default: /* [puts] or * [puts some bad number of arguments...] */ Tcl_WrongNumArgs(interp, 1, objv, "?-nonewline? ?channel? string"); @@ -1627,7 +1627,7 @@ Tcl_SocketObjCmd( } break; default: - Tcl_Panic("Tcl_SocketObjCmd: bad option index to SocketOptions"); + TCL_UNREACHABLE(); } } if (server) { @@ -1832,6 +1832,8 @@ Tcl_FcopyObjCmd( case FcopyCommand: cmdPtr = objv[i+1]; break; + default: + TCL_UNREACHABLE(); } } @@ -1898,6 +1900,8 @@ ChanPendingObjCmd( Tcl_SetObjResult(interp, Tcl_NewWideIntObj(Tcl_OutputBuffered(chan))); } break; + default: + TCL_UNREACHABLE(); } return TCL_OK; } diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c index beb4d2c..d2d9d7a 100644 --- a/generic/tclIORChan.c +++ b/generic/tclIORChan.c @@ -2108,6 +2108,8 @@ EncodeEventMask( case EVENT_WRITE: events |= TCL_WRITABLE; break; + default: + TCL_UNREACHABLE(); } listc --; } diff --git a/generic/tclIcu.c b/generic/tclIcu.c index 3110281..a375d62 100644 --- a/generic/tclIcu.c +++ b/generic/tclIcu.c @@ -798,7 +798,7 @@ IcuConverttoDString( if (U_SUCCESS(status)) { break; } - /* FALLTHRU */ + TCL_FALLTHROUGH(); default: Tcl_DStringFree(dsOutPtr); ucnv_close(ucnvPtr); @@ -878,7 +878,7 @@ IcuBytesToUCharDString( if (U_SUCCESS(status)) { break; } - /* FALLTHRU */ + TCL_FALLTHROUGH(); default: Tcl_DStringFree(dsOutPtr); ucnv_close(ucnvPtr); @@ -974,7 +974,7 @@ IcuNormalizeUCharDString( if (U_SUCCESS(status)) { break; } - /* FALLTHRU */ + TCL_FALLTHROUGH(); default: Tcl_DStringFree(dsOutPtr); return IcuError(interp, "String normalization failed", status); @@ -1037,6 +1037,8 @@ static int IcuParseConvertOptions( Tcl_SetObjResult(interp, Tcl_NewStringObj("Option -failindex not implemented.", TCL_INDEX_NONE)); return TCL_ERROR; + default: + TCL_UNREACHABLE(); } } *strictPtr = strict; @@ -1205,6 +1207,8 @@ IcuNormalizeObjCmd( return TCL_ERROR; } break; + default: + TCL_UNREACHABLE(); } } @@ -1359,7 +1363,8 @@ TclIcuInit( /* Going back down to ICU version 60 */ while ((icu_fns.libs[0] == NULL) && (icuversion[1] >= '6')) { if (--icuversion[2] < '0') { - icuversion[1]--; icuversion[2] = '9'; + icuversion[1]--; + icuversion[2] = '9'; } #if defined(__CYGWIN__) i = 2; diff --git a/generic/tclInt.h b/generic/tclInt.h index 5aa7980..f088545 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -141,6 +141,32 @@ # define Tcl_ConditionFinalize(condPtr) #endif +// A way to mark a code path as unreachable. +#ifndef TCL_UNREACHABLE +#if defined(__STDC__) && __STDC__ >= 202311L +#include +#define TCL_UNREACHABLE() unreachable() +#elif defined(__GNUC__) +#define TCL_UNREACHABLE() __builtin_unreachable() +#elif defined(_MSC_VER) +#include +#define TCL_UNREACHABLE() __assume(false) +#else +#define TCL_UNREACHABLE() ((void) 0) +#endif +#endif // TCL_UNREACHABLE + +#ifndef TCL_FALLTHROUGH +#if defined(__STDC__) && __STDC__ >= 202311L +#define TCL_FALLTHROUGH() [[fallthrough]] +#elif defined(__GNUC__) +#define TCL_FALLTHROUGH() __attribute__((fallthrough)) +#else +// Nothing documented as an alternative to the standard [[fallthrough]]. +#define TCL_FALLTHROUGH() ((void) 0) +#endif +#endif // TCL_FALLTHROUGH + /* * The following procedures allow namespaces to be customized to support * special name resolution rules for commands/variables. diff --git a/generic/tclInterp.c b/generic/tclInterp.c index 91e9814..d58119e 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -756,6 +756,8 @@ NRInterpCmd( case OPT_LAST: i++; goto endOfForLoop; + default: + TCL_UNREACHABLE(); } } @@ -1022,8 +1024,7 @@ NRInterpCmd( case LIMIT_TYPE_TIME: return ChildTimeLimitCmd(interp, childInterp, 4, objc, objv); default: - Tcl_Panic("unreachable"); - return TCL_ERROR; + TCL_UNREACHABLE(); } } case OPT_MARKTRUSTED: @@ -1147,8 +1148,7 @@ NRInterpCmd( return TCL_OK; } default: - Tcl_Panic("unreachable"); - return TCL_ERROR; + TCL_UNREACHABLE(); } } @@ -2677,9 +2677,10 @@ NRChildCmd( return ChildCommandLimitCmd(interp, childInterp, 3, objc,objv); case LIMIT_TYPE_TIME: return ChildTimeLimitCmd(interp, childInterp, 3, objc, objv); + default: + TCL_UNREACHABLE(); } } - break; case OPT_MARKTRUSTED: if (objc != 2) { Tcl_WrongNumArgs(interp, 2, objv, NULL); @@ -2692,6 +2693,8 @@ NRChildCmd( return TCL_ERROR; } return ChildRecursionLimit(interp, childInterp, objc - 2, objv + 2); + default: + TCL_UNREACHABLE(); } return TCL_ERROR; @@ -4529,6 +4532,8 @@ ChildCommandLimitCmd( Tcl_NewWideIntObj(Tcl_LimitGetCommands(childInterp))); } break; + default: + TCL_UNREACHABLE(); } return TCL_OK; } else if ((objc-consumedObjc) & 1 /* isOdd(objc-consumedObjc) */) { @@ -4579,6 +4584,8 @@ ChildCommandLimitCmd( return TCL_ERROR; } break; + default: + TCL_UNREACHABLE(); } } if (scriptObj != NULL) { @@ -4729,6 +4736,8 @@ ChildTimeLimitCmd( Tcl_SetObjResult(interp, Tcl_NewWideIntObj(limitMoment.sec)); } break; + default: + TCL_UNREACHABLE(); } return TCL_OK; } else if ((objc-consumedObjc) & 1 /* isOdd(objc-consumedObjc) */) { @@ -4802,6 +4811,8 @@ ChildTimeLimitCmd( } limitMoment.sec = (long long) tmp; break; + default: + TCL_UNREACHABLE(); } } if (milliObj != NULL || secObj != NULL) { diff --git a/generic/tclLink.c b/generic/tclLink.c index d2fb2af..746d74a 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -1316,7 +1316,7 @@ ObjValue( Tcl_Obj *uwObj; TclNewUIntObj(uwObj, linkPtr->lastValue.uw); return uwObj; - } + } case TCL_LINK_STRING: p = LinkedVar(char *); diff --git a/generic/tclLoad.c b/generic/tclLoad.c index 96691cc..7e68744 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -156,13 +156,14 @@ Tcl_LoadObjCmd( &index) != TCL_OK) { return TCL_ERROR; } - ++objv; --objc; + ++objv; + --objc; if (LOAD_GLOBAL == index) { flags |= TCL_LOAD_GLOBAL; } else if (LOAD_LAZY == index) { flags |= TCL_LOAD_LAZY; } else { - break; + break; } } if ((objc < 2) || (objc > 4)) { @@ -598,6 +599,8 @@ Tcl_UnloadObjCmd( case UNLOAD_LAST: /* -- */ i++; goto endOfForLoop; + default: + TCL_UNREACHABLE(); } } endOfForLoop: diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index fed0dda..5acb014 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -4770,15 +4770,14 @@ NamespaceWhichCmd( TclNewObj(resultPtr); switch (lookupType) { - case 0: { /* -command */ + case 0:; /* -command */ Tcl_Command cmd = Tcl_GetCommandFromObj(interp, objv[objc-1]); if (cmd != NULL) { Tcl_GetCommandFullName(interp, cmd, resultPtr); } break; - } - case 1: { /* -variable */ + case 1:; /* -variable */ Tcl_Var var = Tcl_FindNamespaceVar(interp, TclGetString(objv[objc-1]), NULL, /*flags*/ 0); @@ -4786,7 +4785,8 @@ NamespaceWhichCmd( Tcl_GetVariableFullName(interp, var, resultPtr); } break; - } + default: + TCL_UNREACHABLE(); } Tcl_SetObjResult(interp, resultPtr); return TCL_OK; diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index 36b9e9c..f7bb969 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -1207,13 +1207,7 @@ TclOOSelfObjCmd( } else if (mPtr->declaringObjectPtr != NULL) { declarerPtr = mPtr->declaringObjectPtr; } else { - /* - * This should be unreachable code. - */ - - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "method without declarer!", TCL_AUTO_LENGTH)); - return TCL_ERROR; + TCL_UNREACHABLE(); } result[0] = TclOOObjectName(interp, declarerPtr); @@ -1239,13 +1233,7 @@ TclOOSelfObjCmd( } else if (mPtr->declaringObjectPtr != NULL) { declarerPtr = mPtr->declaringObjectPtr; } else { - /* - * This should be unreachable code. - */ - - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "method without declarer!", TCL_AUTO_LENGTH)); - return TCL_ERROR; + TCL_UNREACHABLE(); } result[0] = TclOOObjectName(interp, declarerPtr); @@ -1284,13 +1272,7 @@ TclOOSelfObjCmd( } else if (mPtr->declaringObjectPtr != NULL) { declarerPtr = mPtr->declaringObjectPtr; } else { - /* - * This should be unreachable code. - */ - - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "method without declarer!", TCL_AUTO_LENGTH)); - return TCL_ERROR; + TCL_UNREACHABLE(); } result[0] = TclOOObjectName(interp, declarerPtr); result[1] = mPtr->namePtr; @@ -1302,8 +1284,9 @@ TclOOSelfObjCmd( TclNewIndexObj(result[1], contextPtr->index); Tcl_SetObjResult(interp, Tcl_NewListObj(2, result)); return TCL_OK; + default: + TCL_UNREACHABLE(); } - return TCL_ERROR; } /* diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index 04d53fc..6c18b85 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -1647,6 +1647,7 @@ AddClassFiltersToCallContext( AddClassFiltersToCallContext(oPtr, superPtr, cbPtr, doneFilters, flags); } + TCL_FALLTHROUGH(); case 0: return; } @@ -1734,7 +1735,7 @@ AddPrivatesFromClassChainToCallContext( return 1; } } - /* FALLTHRU */ + TCL_FALLTHROUGH(); case 0: return 0; } @@ -1829,7 +1830,7 @@ AddSimpleClassChainToCallContext( privateDanger |= AddSimpleClassChainToCallContext(superPtr, methodNameObj, cbPtr, doneFilters, flags, filterDecl); } - /* FALLTHRU */ + TCL_FALLTHROUGH(); case 0: return privateDanger; } @@ -2067,6 +2068,7 @@ AddSimpleClassDefineNamespaces( FOREACH(superPtr, classPtr->superclasses) { AddSimpleClassDefineNamespaces(superPtr, definePtr, flags); } + TCL_FALLTHROUGH(); case 0: return; } diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index efc88bd..e029649 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -1738,9 +1738,9 @@ TclOODefineDefnNsObjCmd( * Update the correct field of the class definition. */ - if (kind) { + if (kind) { // -instance storagePtr = &clsPtr->objDefinitionNs; - } else { + } else { // -class storagePtr = &clsPtr->clsDefinitionNs; } if (*storagePtr != NULL) { @@ -2097,6 +2097,8 @@ TclOODefineMethodObjCmd( case MODE_UNEXPORT: isPublic = 0; break; + default: + TCL_UNREACHABLE(); } } else { if (IsPrivateDefine(interp)) { diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c index 56562dc..bec931a 100644 --- a/generic/tclOOInfo.c +++ b/generic/tclOOInfo.c @@ -485,6 +485,8 @@ InfoObjectIsACmd( return TCL_ERROR; } break; + default: + TCL_UNREACHABLE(); } /* @@ -538,6 +540,8 @@ InfoObjectIsACmd( result = TclOOIsReachable(o2Ptr->classPtr, oPtr->selfCls); } break; + default: + TCL_UNREACHABLE(); } Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result)); return TCL_OK; @@ -628,6 +632,8 @@ InfoObjectMethodsCmd( return TCL_ERROR; } break; + default: + TCL_UNREACHABLE(); } } } @@ -1145,9 +1151,9 @@ InfoClassDefnNsCmd( return TCL_ERROR; } - if (kind) { + if (kind) { // -instance nsNamePtr = clsPtr->objDefinitionNs; - } else { + } else { // -class nsNamePtr = clsPtr->clsDefinitionNs; } if (nsNamePtr) { @@ -1412,6 +1418,8 @@ InfoClassMethodsCmd( return TCL_ERROR; } break; + default: + TCL_UNREACHABLE(); } } } @@ -1427,6 +1435,8 @@ InfoClassMethodsCmd( case SCOPE_UNEXPORTED: flag = 0; break; + default: + TCL_UNREACHABLE(); } } diff --git a/generic/tclOOProp.c b/generic/tclOOProp.c index 8d75aaf..35c84e7 100644 --- a/generic/tclOOProp.c +++ b/generic/tclOOProp.c @@ -1099,6 +1099,8 @@ TclOODefinePropertyCmd( return TCL_ERROR; } break; + default: + TCL_UNREACHABLE(); } } @@ -1221,6 +1223,8 @@ TclOOInfoClassPropCmd( case PROP_WRITABLE: writable = 1; break; + default: + TCL_UNREACHABLE(); } } @@ -1279,6 +1283,8 @@ TclOOInfoObjectPropCmd( case PROP_WRITABLE: writable = 1; break; + default: + TCL_UNREACHABLE(); } } diff --git a/generic/tclParse.c b/generic/tclParse.c index dca351c..88368cc 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -1382,7 +1382,8 @@ Tcl_ParseVarName( */ if (*src == '{') { - char ch; int braceCount = 0; + char ch; + int braceCount = 0; src++; numBytes--; tokenPtr->type = TCL_TOKEN_TEXT; @@ -1392,8 +1393,12 @@ Tcl_ParseVarName( ch = *src; while (numBytes && (braceCount>0 || ch != '}')) { switch (ch) { - case '{': braceCount++; break; - case '}': braceCount--; break; + case '{': + braceCount++; + break; + case '}': + braceCount--; + break; case '\\': /* if 2 or more left, consume 2, else consume * just the \ and let it run into the end */ diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index db1a96a..02aa402 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -679,10 +679,7 @@ TclPathPart( } } default: - /* We should never get here */ - Tcl_Panic("Bad portion to TclPathPart"); - /* For less clever compilers */ - return NULL; + TCL_UNREACHABLE(); } } else if (fsPathPtr->cwdPtr != NULL) { /* Relative path */ diff --git a/generic/tclPkg.c b/generic/tclPkg.c index fc48631..de7f6cf 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -1098,13 +1098,12 @@ TclNRPackageObjCmd( } switch (optionIndex) { case PKG_FILES: { - PkgFiles *pkgFiles; - if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "package"); return TCL_ERROR; } - pkgFiles = (PkgFiles *) Tcl_GetAssocData(interp, "tclPkgFiles", NULL); + PkgFiles *pkgFiles = (PkgFiles *) + Tcl_GetAssocData(interp, "tclPkgFiles", NULL); if (pkgFiles) { Tcl_HashEntry *entry = Tcl_FindHashEntry(&pkgFiles->table, TclGetString(objv[2])); @@ -1116,12 +1115,11 @@ TclNRPackageObjCmd( break; } case PKG_FORGET: { - const char *keyString; PkgFiles *pkgFiles = (PkgFiles *) Tcl_GetAssocData(interp, "tclPkgFiles", NULL); for (i = 2; i < objc; i++) { - keyString = TclGetString(objv[i]); + const char *keyString = TclGetString(objv[i]); if (pkgFiles) { hPtr = Tcl_FindHashEntry(&pkgFiles->table, keyString); if (hPtr) { @@ -1157,8 +1155,7 @@ TclNRPackageObjCmd( } case PKG_IFNEEDED: { Tcl_Size length; - int res; - char *argv3i, *avi; + char *argv3i; if ((objc != 4) && (objc != 5)) { Tcl_WrongNumArgs(interp, 2, objv, "package version ?script?"); @@ -1183,13 +1180,14 @@ TclNRPackageObjCmd( for (availPtr = pkgPtr->availPtr, prevPtr = NULL; availPtr != NULL; prevPtr = availPtr, availPtr = availPtr->nextPtr) { + char *avi; if (CheckVersionAndConvert(interp, availPtr->version, &avi, NULL) != TCL_OK) { Tcl_Free(argv3i); return TCL_ERROR; } - res = CompareVersions(avi, argv3i, NULL); + int res = CompareVersions(avi, argv3i, NULL); Tcl_Free(avi); if (res == 0) { @@ -1394,9 +1392,7 @@ TclNRPackageObjCmd( return TCL_OK; } break; - case PKG_UNKNOWN: { - Tcl_Size length; - + case PKG_UNKNOWN: if (objc == 2) { if (iPtr->packageUnknown != NULL) { Tcl_SetObjResult(interp, @@ -1406,6 +1402,7 @@ TclNRPackageObjCmd( if (iPtr->packageUnknown != NULL) { Tcl_Free(iPtr->packageUnknown); } + Tcl_Size length; argv2 = TclGetStringFromObj(objv[2], &length); if (argv2[0] == 0) { iPtr->packageUnknown = NULL; @@ -1417,7 +1414,6 @@ TclNRPackageObjCmd( return TCL_ERROR; } break; - } case PKG_PREFER: { static const char *const pkgPreferOptions[] = { "latest", "stable", NULL @@ -1528,7 +1524,7 @@ TclNRPackageObjCmd( break; } default: - Tcl_Panic("Tcl_PackageObjCmd: bad option index to pkgOptions"); + TCL_UNREACHABLE(); } return TCL_OK; } diff --git a/generic/tclProc.c b/generic/tclProc.c index 4455602..cc3d5fb 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -1761,7 +1761,8 @@ TclNRInterpProcCore( } if (TCL_DTRACE_PROC_INFO_ENABLED() && iPtr->cmdFramePtr) { Tcl_Obj *info = TclInfoFrame(interp, iPtr->cmdFramePtr); - const char *a[6]; Tcl_Size i[2]; + const char *a[6]; + Tcl_Size i[2]; TclDTraceInfo(info, a, i); TCL_DTRACE_PROC_INFO(a[0], a[1], a[2], a[3], i[0], i[1], a[4], a[5]); @@ -1874,8 +1875,7 @@ InterpProcNR2( ((result == TCL_BREAK) ? "break" : "continue"))); Tcl_SetErrorCode(interp, "TCL", "RESULT", "UNEXPECTED", (char *)NULL); result = TCL_ERROR; - - /* FALLTHRU */ + TCL_FALLTHROUGH(); case TCL_ERROR: /* diff --git a/generic/tclProcess.c b/generic/tclProcess.c index bed3a60..8a592cd 100644 --- a/generic/tclProcess.c +++ b/generic/tclProcess.c @@ -499,7 +499,8 @@ ProcessStatusObjCmd( &index) != TCL_OK) { return TCL_ERROR; } - ++objv; --objc; + ++objv; + --objc; if (STATUS_WAIT == index) { options = 0; } else { diff --git a/generic/tclScan.c b/generic/tclScan.c index ba7cb72..feddedc 100644 --- a/generic/tclScan.c +++ b/generic/tclScan.c @@ -396,11 +396,11 @@ ValidateFormat( format += TclUtfToUniChar(format, &ch); break; } - /* FALLTHRU */ + TCL_FALLTHROUGH(); case 'j': case 'q': flags |= SCAN_LONGER; - /* FALLTHRU */ + TCL_FALLTHROUGH(); case 'h': format += TclUtfToUniChar(format, &ch); } @@ -422,7 +422,7 @@ ValidateFormat( Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADWIDTH", (char *)NULL); goto error; } - /* FALLTHRU */ + TCL_FALLTHROUGH(); case 'n': case 's': if (flags & (SCAN_LONGER|SCAN_BIG)) { @@ -436,9 +436,7 @@ ValidateFormat( Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADSIZE", (char *)NULL); goto error; } - /* - * Fall through! - */ + TCL_FALLTHROUGH(); case 'd': case 'e': case 'E': @@ -749,11 +747,11 @@ Tcl_ScanObjCmd( format += TclUtfToUniChar(format, &ch); break; } - /* FALLTHRU */ + TCL_FALLTHROUGH(); case 'j': case 'q': flags |= SCAN_LONGER; - /* FALLTHRU */ + TCL_FALLTHROUGH(); case 'h': format += TclUtfToUniChar(format, &ch); } diff --git a/generic/tclStrIdxTree.c b/generic/tclStrIdxTree.c index 07accc2..c6cf5ff 100644 --- a/generic/tclStrIdxTree.c +++ b/generic/tclStrIdxTree.c @@ -524,12 +524,12 @@ TclStrIdxTreeTestObjCmd( case O_INDEX: case O_PUTS_INDEX: { - Tcl_Obj **lstv; - Tcl_Size i, lstc; TclStrIdxTree idxTree = {NULL, NULL}; - i = 1; + Tcl_Size i = 1; while (++i < objc) { + Tcl_Obj **lstv; + Tcl_Size lstc; if (TclListObjGetElements(interp, objv[i], &lstc, &lstv) != TCL_OK) { return TCL_ERROR; @@ -542,6 +542,8 @@ TclStrIdxTreeTestObjCmd( TclStrIdxTreeFree(idxTree.firstPtr); break; } + default: + TCL_UNREACHABLE(); } return TCL_OK; diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index 69aafaa..fbb2184 100644 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -672,7 +672,7 @@ TclParseNumber( state = SIGNUM; break; } - /* FALLTHROUGH */ + TCL_FALLTHROUGH(); case SIGNUM: /* @@ -768,7 +768,7 @@ TclParseNumber( acceptState = state; acceptPoint = p; acceptLen = len; - /* FALLTHROUGH */ + TCL_FALLTHROUGH(); case ZERO_O: zeroo: if (c == '0') { @@ -847,7 +847,7 @@ TclParseNumber( acceptState = state; acceptPoint = p; acceptLen = len; - /* FALLTHROUGH */ + TCL_FALLTHROUGH(); case ZERO_X: zerox: @@ -911,7 +911,7 @@ TclParseNumber( acceptState = state; acceptPoint = p; acceptLen = len; - /* FALLTHRU */ + TCL_FALLTHROUGH(); case ZERO_B: zerob: if (c == '0') { @@ -972,7 +972,7 @@ TclParseNumber( } state = DECIMAL; flags |= TCL_PARSE_INTEGER_ONLY; - /* FALLTHROUGH */ + TCL_FALLTHROUGH(); case DECIMAL: /* @@ -1024,7 +1024,7 @@ TclParseNumber( state = EXPONENT_START; break; } - /* FALLTHROUGH */ + TCL_FALLTHROUGH(); case LEADING_RADIX_POINT: if (c == '0') { @@ -1066,7 +1066,7 @@ TclParseNumber( state = EXPONENT_SIGNUM; break; } - /* FALLTHROUGH */ + TCL_FALLTHROUGH(); case EXPONENT_SIGNUM: /* @@ -1186,7 +1186,7 @@ TclParseNumber( state = sNANFINISH; break; } - /* FALLTHROUGH */ + TCL_FALLTHROUGH(); case sNANPAREN: if (TclIsSpaceProcM(c)) { break; @@ -1515,7 +1515,7 @@ TclParseNumber( #endif case INITIAL: /* This case only to silence compiler warning. */ - Tcl_Panic("TclParseNumber: state INITIAL can't happen here"); + TCL_UNREACHABLE(); } } @@ -2312,22 +2312,28 @@ NormalizeRightward( Tcl_WideUInt w = *wPtr; if (!(w & (Tcl_WideUInt) 0xFFFFFFFF)) { - w >>= 32; rv += 32; + w >>= 32; + rv += 32; } if (!(w & (Tcl_WideUInt) 0xFFFF)) { - w >>= 16; rv += 16; + w >>= 16; + rv += 16; } if (!(w & (Tcl_WideUInt) 0xFF)) { - w >>= 8; rv += 8; + w >>= 8; + rv += 8; } if (!(w & (Tcl_WideUInt) 0xF)) { - w >>= 4; rv += 4; + w >>= 4; + rv += 4; } if (!(w & 0x3)) { - w >>= 2; rv += 2; + w >>= 2; + rv += 2; } if (!(w & 0x1)) { - w >>= 1; ++rv; + w >>= 1; + ++rv; } *wPtr = w; return rv; @@ -3175,7 +3181,9 @@ ShorteningInt64Conversion( if (b < S) { b = 10 * b; - ++m2plus; ++m2minus; ++m5; + ++m2plus; + ++m2minus; + ++m5; ilim = ilim1; --k; } @@ -3554,7 +3562,9 @@ ShorteningBignumConversionPowD( if ((err == MP_OKAY) && (b.used <= sd)) { err = mp_mul_d(&b, 10, &b); - ++m2plus; ++m2minus; ++m5; + ++m2plus; + ++m2minus; + ++m5; ilim = ilim1; --k; } @@ -3594,7 +3604,8 @@ ShorteningBignumConversionPowD( if (b.used > sd+1 || digit >= 10) { Tcl_Panic("wrong digit!"); } - --b.used; mp_clamp(&b); + --b.used; + mp_clamp(&b); } /* @@ -4570,9 +4581,11 @@ TclDoubleDigits( */ if (b2 >= s2 && s2 > 0) { - b2 -= s2; s2 = 0; + b2 -= s2; + s2 = 0; } else if (s2 >= b2 && b2 > 0) { - s2 -= b2; b2 = 0; + s2 -= b2; + b2 = 0; } if (s5+1 < N_LOG2POW5 && s2+1 + log2pow5[s5+1] < 64) { diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 7964142..2b0fbd7 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -2165,7 +2165,6 @@ Tcl_AppendFormatToObj( } case 'u': - /* FALLTHRU */ case 'd': case 'o': case 'p': @@ -2773,7 +2772,7 @@ AppendPrintfToObjVA( if (sizeof(size_t) == sizeof(Tcl_WideInt)) { size = 2; } - /* FALLTHRU */ + TCL_FALLTHROUGH(); case 'c': case 'i': case 'u': @@ -2868,7 +2867,7 @@ AppendPrintfToObjVA( break; case 'h': size = -1; - /* FALLTHRU */ + TCL_FALLTHROUGH(); default: p++; } @@ -3272,7 +3271,8 @@ TclStringCat( } while (--oc); } else { /* Result will be concat of string reps. Pre-size it. */ - ov = objv; oc = objc; + ov = objv; + oc = objc; do { Tcl_Obj *pendingPtr = NULL; @@ -3356,7 +3356,8 @@ TclStringCat( return objv[first]; } - objv += first; objc = (last - first + 1); + objv += first; + objc = (last - first + 1); inPlace = (flags & TCL_STRING_IN_PLACE) && !Tcl_IsShared(*objv); if (binary) { @@ -3371,7 +3372,8 @@ TclStringCat( if (inPlace) { Tcl_Size start = 0; - objResultPtr = *objv++; objc--; + objResultPtr = *objv++; + objc--; (void)Tcl_GetBytesFromObj(NULL, objResultPtr, &start); dst = Tcl_SetByteArrayLength(objResultPtr, length) + start; } else { @@ -3401,7 +3403,8 @@ TclStringCat( if (inPlace) { Tcl_Size start; - objResultPtr = *objv++; objc--; + objResultPtr = *objv++; + objc--; /* Ugly interface! Force resize of the unicode array. */ (void)Tcl_GetUnicodeFromObj(objResultPtr, &start); @@ -3452,7 +3455,8 @@ TclStringCat( if (inPlace) { Tcl_Size start; - objResultPtr = *objv++; objc--; + objResultPtr = *objv++; + objc--; (void)TclGetStringFromObj(objResultPtr, &start); if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) { diff --git a/generic/tclTest.c b/generic/tclTest.c index 72ed211..ebc859a 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -8765,7 +8765,7 @@ TestLutilCmd( Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); break; } - /* FALLTHRU */ + TCL_FALLTHROUGH(); case LUTIL_DIFFINDEX: nCmp = nL1 <= nL2 ? nL1 : nL2; for (i = 0; i < nCmp; ++i) { diff --git a/generic/tclTimer.c b/generic/tclTimer.c index 5ffb29b..86c1f2c 100644 --- a/generic/tclTimer.c +++ b/generic/tclTimer.c @@ -979,7 +979,7 @@ Tcl_AfterObjCmd( } break; default: - Tcl_Panic("Tcl_AfterObjCmd: bad subcommand index to afterSubCmds"); + TCL_UNREACHABLE(); } return TCL_OK; } diff --git a/generic/tclTrace.c b/generic/tclTrace.c index f396245..e43eba8 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -250,9 +250,9 @@ Tcl_TraceObjCmd( return TCL_ERROR; } return traceSubCmds[typeIndex](interp, optionIndex, objc, objv); - break; } - + default: + TCL_UNREACHABLE(); } return TCL_OK; } @@ -344,6 +344,8 @@ TraceExecutionObjCmd( case TRACE_EXEC_LEAVE_STEP: flags |= TCL_TRACE_LEAVE_DURING_EXEC; break; + default: + TCL_UNREACHABLE(); } } command = TclGetStringFromObj(objv[5], &length); @@ -500,6 +502,8 @@ TraceExecutionObjCmd( Tcl_SetObjResult(interp, resultListPtr); break; } + default: + TCL_UNREACHABLE(); } return TCL_OK; } @@ -580,6 +584,8 @@ TraceCommandObjCmd( case TRACE_CMD_DELETE: flags |= TCL_TRACE_DELETE; break; + default: + TCL_UNREACHABLE(); } } @@ -694,6 +700,8 @@ TraceCommandObjCmd( Tcl_SetObjResult(interp, resultListPtr); break; } + default: + TCL_UNREACHABLE(); } return TCL_OK; } @@ -785,6 +793,8 @@ TraceVariableObjCmd( case TRACE_VAR_WRITE: flags |= TCL_TRACE_WRITES; break; + default: + TCL_UNREACHABLE(); } } command = TclGetStringFromObj(objv[5], &length); @@ -878,6 +888,8 @@ TraceVariableObjCmd( Tcl_SetObjResult(interp, resultListPtr); break; } + default: + TCL_UNREACHABLE(); } return TCL_OK; } diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 385a966..2626f65 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -1133,7 +1133,7 @@ TclScanElement( preferEscape = 1; break; #else - /* FLOW THROUGH */ + TCL_FALLTHROUGH(); #endif /* COMPAT */ case '[': /* TYPE_SUBS */ case '$': /* TYPE_SUBS */ @@ -4451,7 +4451,7 @@ TclReToGlob( case '\\': case '*': case '[': case ']': case '?': /* Only add \ where necessary for glob */ *dsStr++ = '\\'; - /* fall through */ + TCL_FALLTHROUGH(); default: *dsStr++ = *p; break; @@ -4532,7 +4532,7 @@ TclReToGlob( /* Only add \ where necessary for glob */ *dsStr++ = '\\'; anchorLeft = 0; /* prevent exact match */ - /* fall through */ + TCL_FALLTHROUGH(); case '{': case '}': case '(': case ')': case '+': case '.': case '|': case '^': case '$': *dsStr++ = *p; diff --git a/generic/tclVar.c b/generic/tclVar.c index a94744f..53538df 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -3917,6 +3917,8 @@ ArrayNamesCmd( return TCL_ERROR; } break; + default: + TCL_UNREACHABLE(); } if (matched == 0) { continue; @@ -6948,10 +6950,10 @@ ArrayDefaultCmd( SetArrayDefault(varPtr, NULL); } return TCL_OK; - } - /* Unreached */ - return TCL_ERROR; + default: + TCL_UNREACHABLE(); + } } /* diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index b59a091..7530cc2 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -4257,6 +4257,8 @@ ZipFSListObjCmd( return TCL_ERROR; } break; + default: + TCL_UNREACHABLE(); } } else if (objc == 2) { pattern = TclGetString(objv[1]); diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 4bf2e61..538a943 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -395,9 +395,7 @@ ConvertErrorToList( */ default: - TclNewLiteralStringObj(objv[2], "UNKNOWN"); - TclNewIntObj(objv[3], code); - return Tcl_NewListObj(4, objv); + TCL_UNREACHABLE(); } } @@ -2105,10 +2103,10 @@ ZlibCmd( return TCL_ERROR; } switch (option) { - case 0: + case 0: // -header headerDictObj = objv[i + 1]; break; - case 1: + case 1: // -level if (Tcl_GetIntFromObj(interp, objv[i + 1], &level) != TCL_OK) { return TCL_ERROR; @@ -2118,6 +2116,8 @@ ZlibCmd( goto badLevel; } break; + default: + TCL_UNREACHABLE(); } } return Tcl_ZlibDeflate(interp, TCL_ZLIB_FORMAT_GZIP, objv[2], level, @@ -2179,7 +2179,7 @@ ZlibCmd( return TCL_ERROR; } switch (option) { - case 0: + case 0: // -buffersize if (TclGetWideIntFromObj(interp, objv[i + 1], &wideLen) != TCL_OK) { return TCL_ERROR; @@ -2190,10 +2190,12 @@ ZlibCmd( } buffersize = wideLen; break; - case 1: + case 1: // -headerVar headerVarObj = objv[i + 1]; TclNewObj(headerDictObj); break; + default: + TCL_UNREACHABLE(); } } if (Tcl_ZlibInflate(interp, TCL_ZLIB_FORMAT_GZIP, objv[2], @@ -2215,9 +2217,10 @@ ZlibCmd( case CMD_PUSH: /* push mode channel options... * -> channel */ return ZlibPushSubcmd(interp, objc, objv); - } - return TCL_ERROR; + default: // Should be no other options + TCL_UNREACHABLE(); + } badLevel: Tcl_SetObjResult(interp, Tcl_NewStringObj( @@ -2340,7 +2343,7 @@ ZlibStreamSubcmd( format = TCL_ZLIB_FORMAT_GZIP; break; default: - Tcl_Panic("should be unreachable"); + TCL_UNREACHABLE(); } /* @@ -2472,7 +2475,7 @@ ZlibPushSubcmd( format = TCL_ZLIB_FORMAT_GZIP; break; default: - Tcl_Panic("should be unreachable"); + TCL_UNREACHABLE(); } if (TclGetChannelFromObj(interp, objv[3], &chan, &chanMode, 0) != TCL_OK) { @@ -2555,6 +2558,8 @@ ZlibPushSubcmd( } compDictObj = objv[i]; break; + default: + TCL_UNREACHABLE(); } } @@ -2708,9 +2713,9 @@ ZlibStreamCmd( return TCL_ERROR; } return Tcl_ZlibStreamReset(zstream); + default: + TCL_UNREACHABLE(); } - - return TCL_OK; } static int @@ -2787,6 +2792,8 @@ ZlibStreamAddCmd( } compDictObj = objv[++i]; break; + default: + TCL_UNREACHABLE(); } if (flush == -2) { @@ -2895,6 +2902,8 @@ ZlibStreamPutCmd( } compDictObj = objv[++i]; break; + default: + TCL_UNREACHABLE(); } if (flush == -2) { Tcl_SetObjResult(interp, Tcl_NewStringObj( diff --git a/unix/tclUnixChan.c b/unix/tclUnixChan.c index ac4734c..7a44b1e 100644 --- a/unix/tclUnixChan.c +++ b/unix/tclUnixChan.c @@ -1507,15 +1507,15 @@ TtyGetAttributes( parity = 'n'; #ifdef PAREXT switch ((int) (iostate.c_cflag & (PARENB | PARODD | PAREXT))) { - case PARENB : parity = 'e'; break; - case PARENB | PARODD : parity = 'o'; break; - case PARENB | PAREXT : parity = 's'; break; - case PARENB | PARODD | PAREXT : parity = 'm'; break; + case PARENB : parity = 'e'; break; + case PARENB | PARODD : parity = 'o'; break; + case PARENB | PAREXT : parity = 's'; break; + case PARENB | PARODD | PAREXT : parity = 'm'; break; } #else /* !PAREXT */ switch ((int) (iostate.c_cflag & (PARENB | PARODD))) { - case PARENB : parity = 'e'; break; - case PARENB | PARODD : parity = 'o'; break; + case PARENB : parity = 'e'; break; + case PARENB | PARODD : parity = 'o'; break; } #endif /* PAREXT */ diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c index 2942ea1..2aa6d98 100644 --- a/win/tclWinPipe.c +++ b/win/tclWinPipe.c @@ -3457,7 +3457,7 @@ TclPipeThreadStopSignal( SetEvent(evControl); *pipeTIPtr = NULL; - /* FALLTHRU */ + TCL_FALLTHROUGH(); case PTI_STATE_DOWN: return 1; -- cgit v0.12 From 327160f25e7f34985af0cb654d07706b71c81ca4 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Mon, 2 Jun 2025 15:38:43 +0000 Subject: Update changes.md for TIP 716 --- changes.md | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/changes.md b/changes.md index 2523ad7..25e5290 100644 --- a/changes.md +++ b/changes.md @@ -9,6 +9,10 @@ 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) @@ -32,7 +36,7 @@ to the userbase. - [Missing include dir for extensions in non-default locations](https://core.tcl-lang.org/tcl/tktview/3335120320) # Incompatibilities - - No known incompatibilities with the Tcl 9.0.0 public interface. + - [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 - sqlite3 3.49.1 -- cgit v0.12 From a331adea33c1839fdba97de85a497665ff851a45 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Tue, 3 Jun 2025 03:34:57 +0000 Subject: Add stubs function from TIP 716 --- doc/Encoding.3 | 27 ++++++++++++++++++++------- generic/tcl.decls | 8 +++++++- generic/tclDecls.h | 9 +++++++-- generic/tclInt.h | 11 +---------- generic/tclStubInit.c | 3 ++- unix/tclUnixInit.c | 6 ++++++ 6 files changed, 43 insertions(+), 21 deletions(-) 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 \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 diff --git a/generic/tcl.decls b/generic/tcl.decls index 05849fc..175b29a 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2367,13 +2367,19 @@ 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) +} + # ----- BASELINE -- FOR -- 9.1.0 ----- # -declare 691 { +declare 692 { void TclUnusedStubEntry(void) } diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 47f6b9a..694f8b4 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1873,6 +1873,8 @@ EXTERN void Tcl_SetWideUIntObj(Tcl_Obj *objPtr, /* 690 */ EXTERN int Tcl_IsEmpty(Tcl_Obj *obj); /* 691 */ +EXTERN const char * Tcl_GetEncodingNameForUser(Tcl_DString *bufPtr); +/* 692 */ EXTERN void TclUnusedStubEntry(void); typedef struct { @@ -2576,7 +2578,8 @@ typedef struct TclStubs { Tcl_Obj * (*tcl_NewWideUIntObj) (Tcl_WideUInt wideValue); /* 688 */ void (*tcl_SetWideUIntObj) (Tcl_Obj *objPtr, Tcl_WideUInt uwideValue); /* 689 */ int (*tcl_IsEmpty) (Tcl_Obj *obj); /* 690 */ - void (*tclUnusedStubEntry) (void); /* 691 */ + const char * (*tcl_GetEncodingNameForUser) (Tcl_DString *bufPtr); /* 691 */ + void (*tclUnusedStubEntry) (void); /* 692 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -3908,8 +3911,10 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_SetWideUIntObj) /* 689 */ #define Tcl_IsEmpty \ (tclStubsPtr->tcl_IsEmpty) /* 690 */ +#define Tcl_GetEncodingNameForUser \ + (tclStubsPtr->tcl_GetEncodingNameForUser) /* 691 */ #define TclUnusedStubEntry \ - (tclStubsPtr->tclUnusedStubEntry) /* 691 */ + (tclStubsPtr->tclUnusedStubEntry) /* 692 */ #endif /* defined(USE_TCL_STUBS) */ diff --git a/generic/tclInt.h b/generic/tclInt.h index c9c333f..6e41c7d 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3103,16 +3103,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. diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 8839e0b..2fd9bea 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -1498,7 +1498,8 @@ const TclStubs tclStubs = { Tcl_NewWideUIntObj, /* 688 */ Tcl_SetWideUIntObj, /* 689 */ Tcl_IsEmpty, /* 690 */ - TclUnusedStubEntry, /* 691 */ + Tcl_GetEncodingNameForUser, /* 691 */ + TclUnusedStubEntry, /* 692 */ }; /* !END!: Do not edit above this line. */ diff --git a/unix/tclUnixInit.c b/unix/tclUnixInit.c index e59b3ee..ef62400 100644 --- a/unix/tclUnixInit.c +++ b/unix/tclUnixInit.c @@ -694,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); +} + /* *--------------------------------------------------------------------------- * -- cgit v0.12 From 5cced2c4ac882c9fc1cb6a0f2e8c253c9990f6bd Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Tue, 3 Jun 2025 05:00:27 +0000 Subject: Test Tcl_GetEncodingName* functions callable via stubs --- generic/tclTest.c | 25 +++++++++++++++++++++++-- tests/encoding.test | 10 ++++++++++ 2 files changed, 33 insertions(+), 2 deletions(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index 62fa89d..1747006 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -2300,10 +2300,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) { @@ -2377,6 +2379,25 @@ 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; } diff --git a/tests/encoding.test b/tests/encoding.test index dfc8dfb..e504761 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -1176,6 +1176,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 -- cgit v0.12 From d0020e0e235169a18fbfe4e3c5761d7cbf9938a1 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 3 Jun 2025 15:16:07 +0000 Subject: Make the [tailcall] compiler understand {*}; a common case --- generic/tclBasic.c | 3 ++- generic/tclCompCmdsSZ.c | 53 +++++++++++++++++++++++++++++++++++++ generic/tclCompile.c | 5 ++++ generic/tclCompile.h | 1 + generic/tclExecute.c | 49 +++++++++++++++++++++++++++++++--- tests/tailcall.test | 70 +++++++++++++++++++++++++++++++++++++++++++++++++ 6 files changed, 177 insertions(+), 4 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index afc17c5..0d9cd89 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -363,7 +363,7 @@ 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}, @@ -8817,6 +8817,7 @@ TclNRTailcallObjCmd( listPtr = Tcl_NewListObj(objc, objv); TclListObjSetElement(NULL, listPtr, 0, TclNewNamespaceObj(nsPtr)); + Tcl_IncrRefCount(listPtr); iPtr->varFramePtr->tailcallPtr = listPtr; } diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 41bc866..da6d2d0 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -2697,11 +2697,64 @@ TclCompileTailcallCmd( OP( NS_CURRENT); for (i=1 ; itype == TCL_TOKEN_EXPAND_WORD) { + goto tailcallExpanded; + } + } + tokenPtr = parsePtr->tokenPtr; + + for (i=1 ; itokenPtr; + for (i = 1; i < numWords; i++) { + tokenPtr = TokenAfter(tokenPtr); + 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 > (1 << 12)) { + OP4( LIST, build); + if (concat) { + OP( LIST_CONCAT); + } + build = 0; + concat = 1; + } + } + if (build > 0) { + OP4( LIST, build); + if (concat) { + OP( LIST_CONCAT); + } + } + } + OP( TAILCALL_LIST); + return TCL_OK; } /* diff --git a/generic/tclCompile.c b/generic/tclCompile.c index a3008c5..6e2a161 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -955,6 +955,11 @@ InstructionDesc const tclInstructionTable[] = { * 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", -1), + /* Do a tailcall with the words from wordList as the thing to + * tailcall to, and currNs is the namespace scope. + * Stack: ... currNs wordList => ...[NOT REACHED] */ {NULL, 0, 0, 0, {OPERAND_NONE}} }; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 1c184d3..4d68732 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -931,6 +931,7 @@ enum TclInstruction { INST_DICT_REMOVE, INST_IS_EMPTY, INST_JUMP_TABLE_NUM, + INST_TAILCALL_LIST, /* The last opcode */ LAST_INST_OPCODE diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 9a1d8cb..d3712bd 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -2576,8 +2576,7 @@ TEBCresume( } #ifdef TCL_COMPILE_DEBUG - /* FIXME: What is the right thing to trace? */ - { + if (tclTraceExec >= TCL_TRACE_BYTECODE_EXEC_COMMANDS) { Tcl_Size i; TRACE(("%u [", (unsigned) numArgs)); @@ -2587,7 +2586,7 @@ TEBCresume( TRACE_APPEND((" ")); } } - TRACE_APPEND(("] => RETURN...\n")); + TRACE_APPEND(("] => REGISTERED TAILCALL...\n")); } #endif @@ -2609,12 +2608,56 @@ TEBCresume( Tcl_DecrRefCount(iPtr->varFramePtr->tailcallPtr); } iPtr->varFramePtr->tailcallPtr = listPtr; + Tcl_IncrRefCount(listPtr); result = TCL_RETURN; cleanup = numArgs; goto processExceptionReturn; } + 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; + } + + { + Tcl_Obj *listPtr = OBJ_AT_TOS; + // nsPtr = OBJ_UNDER_TOS; // Don't need this variable +#ifdef TCL_COMPILE_DEBUG + if (tclTraceExec >= TCL_TRACE_BYTECODE_EXEC_COMMANDS) { + TRACE(("%s [", O2S(OBJ_UNDER_TOS))); + TclPrintObject(stdout, listPtr, 40); + TRACE_APPEND(("] => REGISTERED TAILCALL...\n")); + } +#endif + + /* + * Push the evaluation of the called command into the NR callback + * stack. + */ + + if (iPtr->varFramePtr->tailcallPtr) { + Tcl_DecrRefCount(iPtr->varFramePtr->tailcallPtr); + } + if (Tcl_IsShared(listPtr)) { + listPtr = Tcl_DuplicateObj(listPtr); + } + // TODO: Consider requiring a blank or the NS at the start of the list. + Tcl_ListObjReplace(NULL, listPtr, 0, 0, 1, &OBJ_UNDER_TOS); + Tcl_IncrRefCount(listPtr); + iPtr->varFramePtr->tailcallPtr = listPtr; + + result = TCL_RETURN; + cleanup = 2; + goto processExceptionReturn; + } + case INST_DONE: if (tosPtr > initTosPtr) { diff --git a/tests/tailcall.test b/tests/tailcall.test index 0016845..6edf8b8 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 -- cgit v0.12 From 08fa057f641cad136e7b47ba9e2bbb74107991c3 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Wed, 4 Jun 2025 03:26:53 +0000 Subject: Update changes.md for TIP's 711, 716, 717 --- changes.md | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/changes.md b/changes.md index 8dcdd87..9827520 100644 --- a/changes.md +++ b/changes.md @@ -10,6 +10,12 @@ 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. +# New public C API + +- [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) + # Performance - [Memory efficient internal representations](https://core.tcl-lang.org/tcl/wiki?name=New+abstract+list+representations) -- cgit v0.12 From 1978e5ad548683dcd5211df12203e5a4701c018d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 4 Jun 2025 07:54:00 +0000 Subject: Simplify tcl::build-info parsing for testConstraint's --- tests/async.test | 2 +- tests/format.test | 2 +- tests/lseq.test | 2 +- tests/winFCmd.test | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/tests/async.test b/tests/async.test index 49a00ff..e2e897a 100644 --- a/tests/async.test +++ b/tests/async.test @@ -21,7 +21,7 @@ catch [list package require -exact tcl::test [info patchlevel]] testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}] testConstraint testasync [llength [info commands testasync]] -testConstraint knownMsvcBug [string match msvc-* [tcl::build-info compiler]] +testConstraint knownMsvcBug [expr {[tcl::build-info msvc]>0}] proc async1 {result code} { global aresult acode diff --git a/tests/format.test b/tests/format.test index 7ebef7a..f3e651b 100644 --- a/tests/format.test +++ b/tests/format.test @@ -20,7 +20,7 @@ testConstraint pointerIs64bit [expr {$tcl_platform(pointerSize) >= 8}] # MSVC uses a broken libc that gets sprintf("%g") wrong. This is a pain # particularly in Continuous Integration, and there isn't anything much we can # do about it. -testConstraint knownMsvcBug [expr {![string match msvc-* [tcl::build-info compiler]]}] +testConstraint knownMsvcBug [expr {[tcl::build-info msvc] eq 0}] test format-1.1 {integer formatting} { format "%*d %d %d %d" 6 34 16923 -12 -1 diff --git a/tests/lseq.test b/tests/lseq.test index c8e13eb..24ccfc8 100644 --- a/tests/lseq.test +++ b/tests/lseq.test @@ -1031,7 +1031,7 @@ test lseq-bug-54329e39c7 {does not cause memory bloat} -constraints { set premem [memusage] p $l set postmem [memusage] - expr {[string match *purify* [tcl::build-info]] || ($postmem - $premem < 10) ? 1 : ($postmem - $premem)} + expr {[tcl::build-info purify] || ($postmem - $premem < 10) ? 1 : ($postmem - $premem)} } -result 1 test lseq-bug-578b7e273c03-1 {Arithmetic Series Objects get wrong precision when end value is not specified} -body { diff --git a/tests/winFCmd.test b/tests/winFCmd.test index a2484da..944f928 100644 --- a/tests/winFCmd.test +++ b/tests/winFCmd.test @@ -29,7 +29,7 @@ testConstraint longFileNames 0 # Some things fail under all Continuous Integration systems for subtle reasons # such as CI often running with elevated privileges in a container. testConstraint notInCIenv [expr {![info exists ::env(CI)]}] -testConstraint knownMsvcBug [expr {![string match msvc-* [tcl::build-info compiler]]}] +testConstraint knownMsvcBug [expr {[tcl::build-info msvc] eq 0}] proc createfile {file {string a}} { set f [open $file w] -- cgit v0.12 From b4f22927e555a8c0dc21b835dba42e3e6193156b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 4 Jun 2025 10:21:51 +0000 Subject: fix leak in lseq.test --- library/init.tcl | 6 +++--- tests/encoding.test | 8 ++++---- tests/lseq.test | 1 + tests/tcltests.tcl | 36 +++++++++++++++++------------------ tests/utfext.test | 54 ++++++++++++++++++++++++++--------------------------- 5 files changed, 53 insertions(+), 52 deletions(-) diff --git a/library/init.tcl b/library/init.tcl index d691baf..5876a29 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -591,9 +591,9 @@ proc auto_execok name { set auto_execs($name) "" set shellBuiltins [list assoc call cd cls color copy date del dir echo \ - erase exit ftype for if md mkdir mklink move path \ - pause prompt rd ren rename rmdir set start time \ - title type ver vol] + erase exit ftype for if md mkdir mklink move path \ + pause prompt rd ren rename rmdir set start time \ + title type ver vol] if {[info exists env(PATHEXT)]} { # Add an initial ; to have the {} extension check first. set execExtensions [split ";$env(PATHEXT)" ";"] diff --git a/tests/encoding.test b/tests/encoding.test index dfc8dfb..9712073 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -1170,10 +1170,10 @@ test encoding-31.1 {encoding system does not change encoding user} -setup { test encoding-31.2 {encoding system on newer Windows always returns utf-8} -body { string equal [encoding system] \ - [expr { - [tcltests::windowsbuildnumber] > 18362 ? - "utf-8" : [tcltests::windowscodepage] - }] + [expr { + [tcltests::windowsbuildnumber] > 18362 ? + "utf-8" : [tcltests::windowscodepage] + }] } -constraints win -result 1 test encoding-bug-6a3e2cb0f0-1 {Bug [6a3e2cb0f0] - invalid bytes in escape encodings} -body { diff --git a/tests/lseq.test b/tests/lseq.test index 24ccfc8..c3adeb7 100644 --- a/tests/lseq.test +++ b/tests/lseq.test @@ -26,6 +26,7 @@ proc memusage {} { if {[llength $line] != 7} { error "Unexpected /proc/pid/statm format" } + close $fd return [lindex $line 5] } testConstraint hasMemUsage [expr {![catch {memusage}]}] diff --git a/tests/tcltests.tcl b/tests/tcltests.tcl index 73080f0..ccb77c3 100644 --- a/tests/tcltests.tcl +++ b/tests/tcltests.tcl @@ -117,24 +117,24 @@ namespace eval ::tcltests { {*}$args } - # Return Windows version as FULLVERSION MAJOR MINOR BUILD REVISION - if {$::tcl_platform(platform) eq "windows"} { - proc windowsversion {} { - set ver [regexp -inline {(\d+).(\d+).(\d+).(\d+)} [exec {*}[auto_execok ver]]] - proc windowsversion {} [list return $ver] - return [windowsversion] - } - proc windowsbuildnumber {} { - return [lindex [windowsversion] 3] - } - proc windowscodepage {} { - # Note we cannot use result of chcp because that returns OEM code page. - package require registry - set cp [registry get HKEY_LOCAL_MACHINE\\SYSTEM\\CurrentControlSet\\Control\\Nls\\CodePage ACP] - proc windowscodepage {} "return cp$cp" - return [windowscodepage] - } - } + # Return Windows version as FULLVERSION MAJOR MINOR BUILD REVISION + if {$::tcl_platform(platform) eq "windows"} { + proc windowsversion {} { + set ver [regexp -inline {(\d+).(\d+).(\d+).(\d+)} [exec {*}[auto_execok ver]]] + proc windowsversion {} [list return $ver] + return [windowsversion] + } + proc windowsbuildnumber {} { + return [lindex [windowsversion] 3] + } + proc windowscodepage {} { + # Note we cannot use result of chcp because that returns OEM code page. + package require registry + set cp [registry get HKEY_LOCAL_MACHINE\\SYSTEM\\CurrentControlSet\\Control\\Nls\\CodePage ACP] + proc windowscodepage {} "return cp$cp" + return [windowscodepage] + } + } } init diff --git a/tests/utfext.test b/tests/utfext.test index bfbb2db..20ca2c4 100644 --- a/tests/utfext.test +++ b/tests/utfext.test @@ -196,15 +196,15 @@ namespace eval utftest { [expr {$frag1Written+$frag2Written}] $decoded } -result [list $status1 1 ok [string length $in] [string length $out] $out] - if {$direction eq "toutf"} { - # Fragmentation but with no more data. - # Only check status. Content output is already checked in above test. - test $cmd-$enc-$id-1 "$cmd - $enc - $hexin - frag=$fragindex - no more data" -constraints testencoding -body { - set frag1Result [testencoding $cmd $enc [string range $in 0 $fragindex-1] {start end} 0 $dstlen frag1Read frag1Written] - lassign $frag1Result frag1Status frag1State frag1Decoded - set frag1Status - } -result syntax - } + if {$direction eq "toutf"} { + # Fragmentation but with no more data. + # Only check status. Content output is already checked in above test. + test $cmd-$enc-$id-1 "$cmd - $enc - $hexin - frag=$fragindex - no more data" -constraints testencoding -body { + set frag1Result [testencoding $cmd $enc [string range $in 0 $fragindex-1] {start end} 0 $dstlen frag1Read frag1Written] + lassign $frag1Result frag1Status frag1State frag1Decoded + set frag1Status + } -result syntax + } } proc testcharlimit {direction enc comment hexin hexout} { @@ -332,45 +332,45 @@ namespace eval utftest { } -result [list [list multibyte 0 \xEF\xBC\x90\xEF\xBC\x91\x00\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF] 4 6 2 [list ok 0 \xC2\x82\x00\xFF\xFF\xFF\xFF\xFF\xFF\xFF] 1 2 1] -constraints testencoding test Tcl_ExternalToUtf-bug-7346adc50f-strict-0 { - truncated input in escape encoding (strict) + truncated input in escape encoding (strict) } -body { - set src [binary decode hex 1b2442242a3b6e24] - list {*}[testencoding Tcl_ExternalToUtf iso2022-jp $src {start end strict} 0 16 srcRead dstWritten charsWritten] $srcRead $dstWritten $charsWritten + set src [binary decode hex 1b2442242a3b6e24] + list {*}[testencoding Tcl_ExternalToUtf iso2022-jp $src {start end strict} 0 16 srcRead dstWritten charsWritten] $srcRead $dstWritten $charsWritten } -result [list syntax 2 [binary decode hex e3818ae8a9a600ffffffffffffffffff] 7 6 2] test Tcl_ExternalToUtf-bug-7346adc50f-strict-1 { - truncated input in escape encoding (strict, partial) + truncated input in escape encoding (strict, partial) } -body { - set src [binary decode hex 1b2442242a3b6e24] - list {*}[testencoding Tcl_ExternalToUtf iso2022-jp $src {start strict} 0 16 srcRead dstWritten charsWritten] $srcRead $dstWritten $charsWritten + set src [binary decode hex 1b2442242a3b6e24] + list {*}[testencoding Tcl_ExternalToUtf iso2022-jp $src {start strict} 0 16 srcRead dstWritten charsWritten] $srcRead $dstWritten $charsWritten } -result [list multibyte 2 [binary decode hex e3818ae8a9a600ffffffffffffffffff] 7 6 2] test Tcl_ExternalToUtf-bug-7346adc50f-replace-0 { - truncated input in escape encoding (replace) + truncated input in escape encoding (replace) } -body { - set src [binary decode hex 1b2442242a3b6e24] - list {*}[testencoding Tcl_ExternalToUtf iso2022-jp $src {start end replace} 0 16 srcRead dstWritten charsWritten] $srcRead $dstWritten $charsWritten + set src [binary decode hex 1b2442242a3b6e24] + list {*}[testencoding Tcl_ExternalToUtf iso2022-jp $src {start end replace} 0 16 srcRead dstWritten charsWritten] $srcRead $dstWritten $charsWritten } -result [list ok 2 [binary decode hex e3818ae8a9a6efbfbd00ffffffffffff] 8 9 3] test Tcl_ExternalToUtf-bug-7346adc50f-replace-1 { - truncated input in escape encoding (replace, partial) + truncated input in escape encoding (replace, partial) } -body { - set src [binary decode hex 1b2442242a3b6e24] - list {*}[testencoding Tcl_ExternalToUtf iso2022-jp $src {start replace} 0 16 srcRead dstWritten charsWritten] $srcRead $dstWritten $charsWritten + set src [binary decode hex 1b2442242a3b6e24] + list {*}[testencoding Tcl_ExternalToUtf iso2022-jp $src {start replace} 0 16 srcRead dstWritten charsWritten] $srcRead $dstWritten $charsWritten } -result [list multibyte 2 [binary decode hex e3818ae8a9a600ffffffffffffffffff] 7 6 2] test Tcl_ExternalToUtf-bug-7346adc50f-tcl8-0 { - truncated input in escape encoding (tcl8) + truncated input in escape encoding (tcl8) } -body { - set src [binary decode hex 1b2442242a3b6e24] - list {*}[testencoding Tcl_ExternalToUtf iso2022-jp $src {start end tcl8} 0 16 srcRead dstWritten charsWritten] $srcRead $dstWritten $charsWritten + set src [binary decode hex 1b2442242a3b6e24] + list {*}[testencoding Tcl_ExternalToUtf iso2022-jp $src {start end tcl8} 0 16 srcRead dstWritten charsWritten] $srcRead $dstWritten $charsWritten } -result [list ok 2 [binary decode hex e3818ae8a9a6efbfbd00ffffffffffff] 8 9 3] test Tcl_ExternalToUtf-bug-7346adc50f-tcl8-1 { - truncated input in escape encoding (tcl8, partial) + truncated input in escape encoding (tcl8, partial) } -body { - set src [binary decode hex 1b2442242a3b6e24] - list {*}[testencoding Tcl_ExternalToUtf iso2022-jp $src {start tcl8} 0 16 srcRead dstWritten charsWritten] $srcRead $dstWritten $charsWritten + set src [binary decode hex 1b2442242a3b6e24] + list {*}[testencoding Tcl_ExternalToUtf iso2022-jp $src {start tcl8} 0 16 srcRead dstWritten charsWritten] $srcRead $dstWritten $charsWritten } -result [list multibyte 2 [binary decode hex e3818ae8a9a600ffffffffffffffffff] 7 6 2] } -- cgit v0.12 From d554c361d3afad314fec5978078e7f829fbed1ef Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 4 Jun 2025 10:51:44 +0000 Subject: Reduce size of build matrices for non-critical commits. This needs deeper Github Actions wizardry. --- .github/workflows/linux-build.yml | 60 ++++++++++++++++++++------ .github/workflows/mac-build.yml | 48 +++++++++++++++++---- .github/workflows/win-build.yml | 90 ++++++++++++++++++++++++++++++--------- 3 files changed, 157 insertions(+), 41 deletions(-) diff --git a/.github/workflows/linux-build.yml b/.github/workflows/linux-build.yml index 74055fb..cbd64d7 100644 --- a/.github/workflows/linux-build.yml +++ b/.github/workflows/linux-build.yml @@ -5,25 +5,57 @@ on: - "main" - "core-9-0-branch" tags: - - "core-**" + - "core-*" permissions: contents: read jobs: + plan: + runs-on: ubuntu-latest + outputs: + gcc: ${{ steps.set-matrix.outputs.gcc }} + steps: + - id: set-matrix + # DO NOT CHANGE THIS MATRIX SPEC; IT AFFECTS OUR COST CONTROLS + run: | + case "$GITHUB_REF_NAME" in + "main" | "core-9-0-branch") + cat >>$GITHUB_OUTPUT <<'EOF' + gcc=<<'EOJ' + { + "config": [ + "", + "CFLAGS=-DTCL_NO_DEPRECATED=1", + "--disable-shared", + "--disable-zipfs", + "--enable-symbols", + "--enable-symbols=mem", + "--enable-symbols=all", + "CFLAGS=-ftrapv", + "CFLAGS=-m32 CPPFLAGS=-m32 LDFLAGS=-m32 --disable-64bit" + ] + } + EOJ + EOF + ;; + *) + cat >>$GITHUB_OUTPUT <<'EOF' + gcc=<<'EOJ' + { + "config": [ + "", + "--enable-symbols=all", + "CFLAGS=-m32 CPPFLAGS=-m32 LDFLAGS=-m32 --disable-64bit" + ] + } + EOJ + EOF + ;; + esac gcc: + needs: plan runs-on: ubuntu-24.04 strategy: - matrix: - config: - - "" - - "CFLAGS=-DTCL_NO_DEPRECATED=1" - - "--disable-shared" - - "--disable-zipfs" - - "--enable-symbols" - - "--enable-symbols=mem" - - "--enable-symbols=all" - - "CFLAGS=-ftrapv" - # Duplicated below - - "CFLAGS=-m32 CPPFLAGS=-m32 LDFLAGS=-m32 --disable-64bit" + matrix: ${{ fromJson(need.plan.outputs.gcc) }} defaults: run: shell: bash @@ -72,10 +104,12 @@ jobs: make install timeout-minutes: 5 - name: Create Distribution Package + if: ${{ matrix.config == '' }} run: | make dist timeout-minutes: 5 - name: Convert Documentation to HTML + if: ${{ matrix.config == '' }} run: | make html-tcl timeout-minutes: 5 diff --git a/.github/workflows/mac-build.yml b/.github/workflows/mac-build.yml index df907d9..3312870 100644 --- a/.github/workflows/mac-build.yml +++ b/.github/workflows/mac-build.yml @@ -9,6 +9,44 @@ on: permissions: contents: read jobs: + plan: + runs-on: ubuntu-latest + outputs: + clang: ${{ steps.set-matrix.outputs.clang }} + steps: + - id: set-matrix + # DO NOT CHANGE THIS MATRIX SPEC; IT AFFECTS OUR COST CONTROLS + run: | + case "$GITHUB_REF_NAME" in + "main" | "core-9-0-branch") + cat >>$GITHUB_OUTPUT <<'EOF' + clang=<<'EOJ' + { + "config": [ + "", + "--disable-shared", + "--disable-zipfs", + "--enable-symbols", + "--enable-symbols=mem", + "--enable-symbols=all" + ] + } + EOJ + EOF + ;; + *) + cat >>$GITHUB_OUTPUT <<'EOF' + clang=<<'EOJ' + { + "config": [ + "", + "--enable-symbols=all" + ] + } + EOJ + EOF + ;; + esac xcode: runs-on: macos-15 defaults: @@ -36,15 +74,9 @@ jobs: timeout-minutes: 15 clang: runs-on: macos-15 + needs: plan strategy: - matrix: - config: - - "" - - "--disable-shared" - - "--disable-zipfs" - - "--enable-symbols" - - "--enable-symbols=mem" - - "--enable-symbols=all" + matrix: ${{ fromJson(need.plan.outputs.clang) }} defaults: run: shell: bash diff --git a/.github/workflows/win-build.yml b/.github/workflows/win-build.yml index 112b656..cfc238d 100644 --- a/.github/workflows/win-build.yml +++ b/.github/workflows/win-build.yml @@ -5,27 +5,80 @@ on: - "main" - "core-9-0-branch" tags: - - "core-**" + - "core-*" permissions: contents: read -env: - ERROR_ON_FAILURES: 1 jobs: + plan: + runs-on: ubuntu-latest + outputs: + msvc: ${{ steps.set-matrix.outputs.msvc }} + gcc: ${{ steps.set-matrix.outputs.gcc }} + steps: + - id: set-matrix + # DO NOT CHANGE THIS MATRIX SPEC; IT AFFECTS OUR COST CONTROLS + run: | + case "$GITHUB_REF_NAME" in + "main" | "core-9-0-branch") + cat >>$GITHUB_OUTPUT <<'EOF' + msvc=<<'EOJ' + { + "config": [ + "", + "CHECKS=nodep", + "OPTS=static", + "OPTS=noembed", + "OPTS=symbols", + "OPTS=symbols STATS=compdbg,memdbg" + ] + } + EOJ + gcc=<<'EOJ' + { + "config": [ + "", + "CFLAGS=-DTCL_NO_DEPRECATED=1", + "--disable-shared", + "--disable-zipfs", + "--enable-symbols", + "--enable-symbols=mem", + "--enable-symbols=all" + ] + } + EOJ + EOF + ;; + *) + cat >>$GITHUB_OUTPUT <<'EOF' + msvc=<<'EOJ' + { + "config": [ + "", + "OPTS=symbols STATS=compdbg,memdbg" + ] + } + EOJ + gcc=<<'EOJ' + { + "config": [ + "", + "--disable-shared", + "--enable-symbols=all" + ] + } + EOJ + EOF + ;; + esac msvc: runs-on: windows-2025 + needs: plan defaults: run: shell: powershell working-directory: win strategy: - matrix: - config: - - "" - - "CHECKS=nodep" - - "OPTS=static" - - "OPTS=noembed" - - "OPTS=symbols" - - "OPTS=symbols STATS=compdbg,memdbg" + matrix: ${{ fromJson(needs.plan.outputs.msvc) }} # Using powershell means we need to explicitly stop on failure steps: - name: Checkout @@ -55,23 +108,18 @@ jobs: throw "nmake exit code: $lastexitcode" } timeout-minutes: 30 + env: + ERROR_ON_FAILURES: 1 gcc: runs-on: windows-2025 + needs: plan defaults: run: shell: msys2 {0} working-directory: win strategy: matrix: - config: - - "" - - "CFLAGS=-DTCL_NO_DEPRECATED=1" - - "--disable-shared" - - "--disable-zipfs" - - "--enable-symbols" - - "--enable-symbols=mem" - - "--enable-symbols=all" - # Using powershell means we need to explicitly stop on failure + config: ${{ fromJson(need.plan.outputs.gcc) }} steps: - name: Install MSYS2 uses: msys2/setup-msys2@v2 @@ -106,6 +154,8 @@ jobs: - name: Run Tests run: make test timeout-minutes: 30 + env: + ERROR_ON_FAILURES: 1 # If you add builds with Wine, be sure to define the environment variable # CI_USING_WINE when running them so that broken tests know not to run. -- cgit v0.12 From b9f37656c8ce3088569a91e6adf8b5f421a316b9 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 5 Jun 2025 08:02:41 +0000 Subject: Correct syntax error in github action command files --- .github/workflows/linux-build.yml | 2 +- .github/workflows/mac-build.yml | 2 +- .github/workflows/win-build.yml | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/.github/workflows/linux-build.yml b/.github/workflows/linux-build.yml index cbd64d7..16324c0 100644 --- a/.github/workflows/linux-build.yml +++ b/.github/workflows/linux-build.yml @@ -55,7 +55,7 @@ jobs: needs: plan runs-on: ubuntu-24.04 strategy: - matrix: ${{ fromJson(need.plan.outputs.gcc) }} + matrix: ${{ fromJson(needs.plan.outputs.gcc) }} defaults: run: shell: bash diff --git a/.github/workflows/mac-build.yml b/.github/workflows/mac-build.yml index 3312870..0161681 100644 --- a/.github/workflows/mac-build.yml +++ b/.github/workflows/mac-build.yml @@ -76,7 +76,7 @@ jobs: runs-on: macos-15 needs: plan strategy: - matrix: ${{ fromJson(need.plan.outputs.clang) }} + matrix: ${{ fromJson(needs.plan.outputs.clang) }} defaults: run: shell: bash diff --git a/.github/workflows/win-build.yml b/.github/workflows/win-build.yml index cfc238d..f6337de 100644 --- a/.github/workflows/win-build.yml +++ b/.github/workflows/win-build.yml @@ -119,7 +119,7 @@ jobs: working-directory: win strategy: matrix: - config: ${{ fromJson(need.plan.outputs.gcc) }} + config: ${{ fromJson(needs.plan.outputs.gcc) }} steps: - name: Install MSYS2 uses: msys2/setup-msys2@v2 -- cgit v0.12 From d4406723ec5885079dd805867b3e236086594430 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 5 Jun 2025 08:12:05 +0000 Subject: Check for tag "core-*", not "core-**" everywhere the same --- .github/workflows/mac-build.yml | 2 +- .github/workflows/onefiledist.yml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/mac-build.yml b/.github/workflows/mac-build.yml index 0161681..01a4a6e 100644 --- a/.github/workflows/mac-build.yml +++ b/.github/workflows/mac-build.yml @@ -5,7 +5,7 @@ on: - "main" - "core-9-0-branch" tags: - - "core-**" + - "core-*" permissions: contents: read jobs: diff --git a/.github/workflows/onefiledist.yml b/.github/workflows/onefiledist.yml index a1af478..66abb05 100644 --- a/.github/workflows/onefiledist.yml +++ b/.github/workflows/onefiledist.yml @@ -5,7 +5,7 @@ on: - "main" - "core-9-0-branch" tags: - - "core-**" + - "core-*" permissions: contents: read jobs: -- cgit v0.12 From 35dc38b268df39cb5398ed1a8e4a33117e000a5e Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 5 Jun 2025 08:17:53 +0000 Subject: rewrite test to use a constraint instead of a silly result condition --- tests/lseq.test | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/tests/lseq.test b/tests/lseq.test index c3adeb7..72e085a 100644 --- a/tests/lseq.test +++ b/tests/lseq.test @@ -30,6 +30,7 @@ proc memusage {} { return [lindex $line 5] } testConstraint hasMemUsage [expr {![catch {memusage}]}] +testConstraint purify [tcl::build-info purify] # Arg errors test lseq-1.1 {error cases} -body { @@ -1025,15 +1026,19 @@ 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 + hasMemUsage !purify } -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-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]}] -- cgit v0.12 From 114535264c39f0609f8cbe9dc46ee6820d18d96b Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 5 Jun 2025 08:42:11 +0000 Subject: Alternate way of testing for no memory bloat in foreach+lseq; should be cross-platform and MUCH less sensitive to configuration --- tests/lseq.test | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) diff --git a/tests/lseq.test b/tests/lseq.test index 72e085a..fefba22 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] @@ -1039,6 +1041,25 @@ test lseq-bug-54329e39c7 {does not cause memory bloat} -constraints { rename p {} unset -nocomplain l } -result ok +test lseq-bug-54329e39c7-bis {does not cause memory bloat} -constraints { + exec memory +} -body { + set memdelta [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-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]}] -- cgit v0.12 From 3170aa3764521f9aa4727b9bb945ed0e741ee60e Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 5 Jun 2025 12:49:07 +0000 Subject: Don't need to save the value from the subprocess in a variable --- tests/lseq.test | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/lseq.test b/tests/lseq.test index fefba22..be6ea93 100644 --- a/tests/lseq.test +++ b/tests/lseq.test @@ -1044,7 +1044,7 @@ test lseq-bug-54329e39c7 {does not cause memory bloat} -constraints { test lseq-bug-54329e39c7-bis {does not cause memory bloat} -constraints { exec memory } -body { - set memdelta [exec [interpreter] << { + exec [interpreter] << { # No change to PEAK memory usage in a fresh interpreter proc memtest script { set start [lindex [split [memory info] \n] 5 end] @@ -1058,7 +1058,7 @@ test lseq-bug-54329e39c7-bis {does not cause memory bloat} -constraints { set l [lseq 1000000] p $l }] - }] + } } -result 0 test lseq-bug-578b7e273c03-1 {Arithmetic Series Objects get wrong precision when end value is not specified} -body { -- cgit v0.12 From e2ce695c5d75867e65834f6c330490f4cd75bb57 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Thu, 5 Jun 2025 13:49:37 +0000 Subject: Start on TIP 649 --- doc/ObjectType.3 | 12 +++-- generic/tclListTypes.c | 127 +++++++++++++++++++++++++++++++++---------------- tests/lrange.test | 12 ++--- 3 files changed, 99 insertions(+), 52 deletions(-) diff --git a/doc/ObjectType.3 b/doc/ObjectType.3 index 1bcf503..1d9b1ae 100644 --- a/doc/ObjectType.3 +++ b/doc/ObjectType.3 @@ -367,10 +367,14 @@ 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. Further, 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. +\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 diff --git a/generic/tclListTypes.c b/generic/tclListTypes.c index d001982..343bcf3 100644 --- a/generic/tclListTypes.c +++ b/generic/tclListTypes.c @@ -23,6 +23,32 @@ #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) +{ +#if 1 + return srcPtr == resultPtr ? Tcl_DuplicateObj(resultPtr) : resultPtr; +#else + /* If we want resultPtr to have no references */ + if (srcPtr == resultPtr || resultPtr->refCount != 0) { + return Tcl_DuplicateObj(resultPtr); + } else { + return resultPtr; + } +#endif +} + + +/* * Returns index of first matching entry in an array of Tcl_Obj, * TCL_INDEX_NONE if not found. */ @@ -435,10 +461,12 @@ LreverseTypeInOper( * Standard Tcl result. * * Side effects: - * Stores the result in *reversedPtrPtr. This may be the same as objPtr, - * 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. + * 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). * *------------------------------------------------------------------------ */ @@ -446,11 +474,14 @@ 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 **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, reversedPtrPtr) == TCL_OK) { + if (TclObjTypeReverse(interp, objPtr, &resultPtr) == TCL_OK) { + *reversedPtrPtr = TclMakeResultObj(objPtr, resultPtr); return TCL_OK; } /* Specialization does not work for this case. Try default path */ @@ -463,17 +494,17 @@ Tcl_ListObjReverse( elemc = TclObjTypeLength(objPtr); } else { if (TclListObjLength(interp, objPtr, &elemc) != TCL_OK) { + *reversedPtrPtr = NULL; return TCL_ERROR; } } - /* If the list is empty, just return it. [Bug 1876793] */ - if (elemc == 0) { - *reversedPtrPtr = objPtr; + if (elemc < 2) { + /* Cannot return the same list as returned Tcl_Obj must be different */ + *reversedPtrPtr = Tcl_DuplicateObj(objPtr); return TCL_OK; } - Tcl_Obj *resultPtr; if (elemc >= LREVERSE_LENGTH_THRESHOLD || objPtr->typePtr != &tclListType) { TclNewObj(resultPtr); TclInvalidateStringRep(resultPtr); @@ -491,6 +522,7 @@ Tcl_ListObjReverse( Tcl_Obj **elemv; if (TclListObjGetElements(interp, objPtr, &elemc, &elemv) != TCL_OK) { + *reversedPtrPtr = NULL; return TCL_ERROR; } resultPtr = Tcl_NewListObj(elemc, NULL); @@ -625,10 +657,12 @@ LrepeatTypeInOper( * Standard Tcl result. * * Side effects: - * Stores the result in *reversedPtrPtr. This may be the same as objPtr, - * 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. + * 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). +. * *------------------------------------------------------------------------ */ @@ -641,6 +675,7 @@ Tcl_ListObjRepeat( 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", @@ -656,6 +691,7 @@ Tcl_ListObjRepeat( /* Final sanity check. Do not exceed limits on max list length. */ if (objc > LIST_MAX/repeatCount) { + *resultPtrPtr = NULL; 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); @@ -675,19 +711,19 @@ Tcl_ListObjRepeat( 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; - if (totalElems) { - 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; - } + 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; } /* @@ -697,7 +733,6 @@ Tcl_ListObjRepeat( * number of times. */ - assert(dataArray || totalElems == 0 ); if (objc == 1) { Tcl_Obj *tmpPtr = objv[0]; @@ -927,6 +962,10 @@ LrangeSlice( return *resultPtrPtr ? TCL_OK : TCL_ERROR; } + /* TODO + * - since Tcl_ListObjRange will dup if returned object is same as source, + * change below to always return a new object if TIP 649 is adopted. + */ if (!Tcl_IsShared(objPtr) && repPtr->refCount < 2) { /* Reuse this objPtr */ repPtr->srcIndex = newSrcIndex; @@ -955,10 +994,12 @@ LrangeSlice( * Standard Tcl result. * * Side effects: - * Stores the result in *resultPtrPtr. This may be the same as objPtr, - * 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. + * 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). * *------------------------------------------------------------------------ */ @@ -972,9 +1013,11 @@ Tcl_ListObjRange( { int result; Tcl_Size srcLen; + Tcl_Obj *resultPtr; result = TclListObjLength(interp, objPtr, &srcLen); if (result != TCL_OK) { + *resultPtrPtr = NULL; return result; } @@ -987,25 +1030,29 @@ Tcl_ListObjRange( /* * If the list is an AbstractList with a specialized slice, use it. * Note this includes rangeType itself. - */ - if (TclObjTypeHasProc(objPtr, sliceProc)) { - return TclObjTypeSlice(interp, objPtr, start, end, resultPtrPtr); - } - - /* + * * 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 (objPtr->typePtr == &tclListType || + if (TclObjTypeHasProc(objPtr, sliceProc)) { + result = TclObjTypeSlice(interp, objPtr, start, end, &resultPtr); + } else if (objPtr->typePtr == &tclListType || !LrangeMeetsLengthCriteria(rangeLen, srcLen)) { /* Conditions not met, create non-abstract list */ - *resultPtrPtr = TclListObjRange(interp, objPtr, start, end); - return *resultPtrPtr ? TCL_OK : TCL_ERROR; + resultPtr = TclListObjRange(interp, objPtr, start, end); + result = resultPtr ? TCL_OK : TCL_ERROR; + } else { + /* Create a lrangeType referencing the original source list */ + result = LrangeNew(objPtr, start, rangeLen, &resultPtr); } - /* Create a lrangeType referencing the original source list */ - return LrangeNew(objPtr, start, rangeLen, resultPtrPtr); + if (result == TCL_OK) { + *resultPtrPtr = TclMakeResultObj(objPtr, resultPtr); + } else { + *resultPtrPtr = NULL; + } + return result; } 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. -- cgit v0.12 From 24d87815020cf0a917811deded98886fead285ee Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Fri, 6 Jun 2025 05:49:35 +0000 Subject: Add new list functions to stubs --- generic/tcl.decls | 16 +++++++++++++++- generic/tclDecls.h | 25 +++++++++++++++++++++++-- generic/tclInt.h | 8 -------- generic/tclStubInit.c | 5 ++++- 4 files changed, 42 insertions(+), 12 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 175b29a..f36ecd5 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2377,9 +2377,23 @@ 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 692 { +declare 695 { void TclUnusedStubEntry(void) } diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 694f8b4..70c0191 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1875,6 +1875,18 @@ 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 { @@ -2579,7 +2591,10 @@ typedef struct TclStubs { void (*tcl_SetWideUIntObj) (Tcl_Obj *objPtr, Tcl_WideUInt uwideValue); /* 689 */ int (*tcl_IsEmpty) (Tcl_Obj *obj); /* 690 */ const char * (*tcl_GetEncodingNameForUser) (Tcl_DString *bufPtr); /* 691 */ - void (*tclUnusedStubEntry) (void); /* 692 */ + 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; @@ -3913,8 +3928,14 @@ extern const TclStubs *tclStubsPtr; (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) /* 692 */ + (tclStubsPtr->tclUnusedStubEntry) /* 695 */ #endif /* defined(USE_TCL_STUBS) */ diff --git a/generic/tclInt.h b/generic/tclInt.h index 6e41c7d..356ac29 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1206,14 +1206,6 @@ TclObjTypeInOperator( return proc(interp, valueObj, listObj, boolResult); } -/* Functions related to abstract list implementations */ -MODULE_SCOPE int -Tcl_ListObjReverse(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Obj **resultPtrPtr); -MODULE_SCOPE int Tcl_ListObjRepeat(Tcl_Interp *interp, Tcl_Size repeatCount, - Tcl_Size objc, Tcl_Obj *const objv[], Tcl_Obj **resultPtrPtr); -MODULE_SCOPE int Tcl_ListObjRange(Tcl_Interp *interp, Tcl_Obj *objPtr, - Tcl_Size start, Tcl_Size end, Tcl_Obj **resultPtrPtr); - /* * The structure below defines an entry in the assocData hash table which is * associated with an interpreter. The entry contains a pointer to a function diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 2fd9bea..6afa675 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -1499,7 +1499,10 @@ const TclStubs tclStubs = { Tcl_SetWideUIntObj, /* 689 */ Tcl_IsEmpty, /* 690 */ Tcl_GetEncodingNameForUser, /* 691 */ - TclUnusedStubEntry, /* 692 */ + Tcl_ListObjReverse, /* 692 */ + Tcl_ListObjRepeat, /* 693 */ + Tcl_ListObjRange, /* 694 */ + TclUnusedStubEntry, /* 695 */ }; /* !END!: Do not edit above this line. */ -- cgit v0.12 From dfa4a65a520195313b036187d4e16e881b94c199 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 6 Jun 2025 08:24:34 +0000 Subject: Move support Tcl script into its own file --- .github/workflows/info.tcl | 7 +++++++ .github/workflows/win-build.yml | 2 +- win/Makefile.in | 2 +- 3 files changed, 9 insertions(+), 2 deletions(-) create mode 100644 .github/workflows/info.tcl diff --git a/.github/workflows/info.tcl b/.github/workflows/info.tcl new file mode 100644 index 0000000..ad57d7d --- /dev/null +++ b/.github/workflows/info.tcl @@ -0,0 +1,7 @@ +puts exe:\t[info nameofexecutable] +puts ver:\t[info patchlevel] +catch { + puts build:\t[tcl::build-info] +} +puts lib:\t[info library] +puts plat:\t[lsort -dictionary -stride 2 [array get tcl_platform]] diff --git a/.github/workflows/win-build.yml b/.github/workflows/win-build.yml index f6337de..04e4040 100644 --- a/.github/workflows/win-build.yml +++ b/.github/workflows/win-build.yml @@ -150,7 +150,7 @@ jobs: - name: Info run: | ulimit -a || echo 'get limit failed' - echo 'puts exe:\t[info nameofexecutable]\nver:\t[info patchlevel]\t[if {![catch tcl::build-info ret]} {set ret}]\nlib:\t[info library]\nplat:\t[lsort -dictionary -stride 2 [array get tcl_platform]]' | make runtest || echo 'get info failed' + make runtest SCRIPT=../.github/workflows/info.tcl || echo 'get info failed' - name: Run Tests run: make test timeout-minutes: 30 diff --git a/win/Makefile.in b/win/Makefile.in index 57bf057..3f28d25 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -1006,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` -- cgit v0.12 From 370566c1e6615b4e724268fcd1e0c7f21c8b3359 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 6 Jun 2025 08:28:16 +0000 Subject: That script can be used on the other two platforms too. Excellent! --- .github/workflows/linux-build.yml | 2 +- .github/workflows/mac-build.yml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/linux-build.yml b/.github/workflows/linux-build.yml index 16324c0..0ef3b7d 100644 --- a/.github/workflows/linux-build.yml +++ b/.github/workflows/linux-build.yml @@ -92,7 +92,7 @@ jobs: - name: Info run: | ulimit -a || echo 'get limit failed' - echo 'puts exe:\t[info nameofexecutable]\nver:\t[info patchlevel]\t[if {![catch tcl::build-info ret]} {set ret}]\nlib:\t[info library]\nplat:\t[lsort -dictionary -stride 2 [array get tcl_platform]]' | make runtest || echo 'get info failed' + make runtest sCRIPT=../.github/workflows/info.tcl || echo 'get info failed' - name: Run Tests run: | make test diff --git a/.github/workflows/mac-build.yml b/.github/workflows/mac-build.yml index 01a4a6e..eecf0c0 100644 --- a/.github/workflows/mac-build.yml +++ b/.github/workflows/mac-build.yml @@ -106,7 +106,7 @@ jobs: - name: Info run: | ulimit -a || echo 'get limit failed' - echo 'puts exe:\t[info nameofexecutable]\nver:\t[info patchlevel]\t[if {![catch tcl::build-info ret]} {set ret}]\nlib:\t[info library]\nplat:\t[lsort -dictionary -stride 2 [array get tcl_platform]]' | make runtest || echo 'get info failed' + make runtest sCRIPT=../.github/workflows/info.tcl || echo 'get info failed' - name: Run Tests run: | make test -- cgit v0.12 From 48c4185146a79ab2384d3f31a17e8ce8c67b7258 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 6 Jun 2025 13:29:37 +0000 Subject: After private testing, this works correctly and is shorter too --- .github/workflows/linux-build.yml | 64 +++++++++++--------------- .github/workflows/mac-build.yml | 56 ++++++++++------------ .github/workflows/win-build.yml | 97 +++++++++++++++++---------------------- 3 files changed, 91 insertions(+), 126 deletions(-) diff --git a/.github/workflows/linux-build.yml b/.github/workflows/linux-build.yml index 0ef3b7d..5194b81 100644 --- a/.github/workflows/linux-build.yml +++ b/.github/workflows/linux-build.yml @@ -12,45 +12,35 @@ jobs: plan: runs-on: ubuntu-latest outputs: - gcc: ${{ steps.set-matrix.outputs.gcc }} + gcc: ${{ steps.matrix.outputs.gcc }} steps: - - id: set-matrix - # DO NOT CHANGE THIS MATRIX SPEC; IT AFFECTS OUR COST CONTROLS + - name: Select build matrix based on branch name + id: matrix run: | - case "$GITHUB_REF_NAME" in - "main" | "core-9-0-branch") - cat >>$GITHUB_OUTPUT <<'EOF' - gcc=<<'EOJ' - { - "config": [ - "", - "CFLAGS=-DTCL_NO_DEPRECATED=1", - "--disable-shared", - "--disable-zipfs", - "--enable-symbols", - "--enable-symbols=mem", - "--enable-symbols=all", - "CFLAGS=-ftrapv", - "CFLAGS=-m32 CPPFLAGS=-m32 LDFLAGS=-m32 --disable-64bit" - ] - } - EOJ - EOF - ;; - *) - cat >>$GITHUB_OUTPUT <<'EOF' - gcc=<<'EOJ' - { - "config": [ - "", - "--enable-symbols=all", - "CFLAGS=-m32 CPPFLAGS=-m32 LDFLAGS=-m32 --disable-64bit" - ] - } - EOJ - EOF - ;; - esac + ( + echo gcc=$(jq -nc '{config: (if env.IsMatched == "true" then env.FULL else env.PARTIAL end) | fromjson }' ) + ) | tee -a $GITHUB_OUTPUT + env: + IsMatched: ${{ github.ref_name == 'main' || github.ref_name == 'core-9-0-branch' }} + # DO NOT CHANGE THESE MATRIX SPECS; IT AFFECTS OUR COST CONTROLS + FULL: > + [ + "", + "CFLAGS=-DTCL_NO_DEPRECATED=1", + "--disable-shared", + "--disable-zipfs", + "--enable-symbols", + "--enable-symbols=mem", + "--enable-symbols=all", + "CFLAGS=-ftrapv", + "CFLAGS=-m32 CPPFLAGS=-m32 LDFLAGS=-m32 --disable-64bit" + ] + PARTIAL: > + [ + "", + "--enable-symbols=all", + "CFLAGS=-m32 CPPFLAGS=-m32 LDFLAGS=-m32 --disable-64bit" + ] gcc: needs: plan runs-on: ubuntu-24.04 diff --git a/.github/workflows/mac-build.yml b/.github/workflows/mac-build.yml index eecf0c0..dcb865d 100644 --- a/.github/workflows/mac-build.yml +++ b/.github/workflows/mac-build.yml @@ -12,41 +12,31 @@ jobs: plan: runs-on: ubuntu-latest outputs: - clang: ${{ steps.set-matrix.outputs.clang }} + clang: ${{ steps.matrix.outputs.clang }} steps: - - id: set-matrix - # DO NOT CHANGE THIS MATRIX SPEC; IT AFFECTS OUR COST CONTROLS + - name: Select build matrix based on branch name + id: matrix run: | - case "$GITHUB_REF_NAME" in - "main" | "core-9-0-branch") - cat >>$GITHUB_OUTPUT <<'EOF' - clang=<<'EOJ' - { - "config": [ - "", - "--disable-shared", - "--disable-zipfs", - "--enable-symbols", - "--enable-symbols=mem", - "--enable-symbols=all" - ] - } - EOJ - EOF - ;; - *) - cat >>$GITHUB_OUTPUT <<'EOF' - clang=<<'EOJ' - { - "config": [ - "", - "--enable-symbols=all" - ] - } - EOJ - EOF - ;; - esac + ( + echo clang=$(jq -nc '{config: (if env.IsMatched == "true" then env.FULL else env.PARTIAL end) | fromjson }' ) + ) | tee -a $GITHUB_OUTPUT + env: + IsMatched: ${{ github.ref_name == 'main' || github.ref_name == 'core-9-0-branch' }} + # DO NOT CHANGE THIS MATRIX SPEC; IT AFFECTS OUR COST CONTROLS + FULL: > + [ + "", + "--disable-shared", + "--disable-zipfs", + "--enable-symbols", + "--enable-symbols=mem", + "--enable-symbols=all" + ] + PARTIAL: > + [ + "", + "--enable-symbols=all" + ] xcode: runs-on: macos-15 defaults: diff --git a/.github/workflows/win-build.yml b/.github/workflows/win-build.yml index 04e4040..f013eec 100644 --- a/.github/workflows/win-build.yml +++ b/.github/workflows/win-build.yml @@ -12,64 +12,49 @@ jobs: plan: runs-on: ubuntu-latest outputs: - msvc: ${{ steps.set-matrix.outputs.msvc }} - gcc: ${{ steps.set-matrix.outputs.gcc }} + msvc: ${{ steps.matrix.outputs.msvc }} + gcc: ${{ steps.matrix.outputs.gcc }} steps: - - id: set-matrix - # DO NOT CHANGE THIS MATRIX SPEC; IT AFFECTS OUR COST CONTROLS + - name: Select build matrix based on branch name + id: matrix run: | - case "$GITHUB_REF_NAME" in - "main" | "core-9-0-branch") - cat >>$GITHUB_OUTPUT <<'EOF' - msvc=<<'EOJ' - { - "config": [ - "", - "CHECKS=nodep", - "OPTS=static", - "OPTS=noembed", - "OPTS=symbols", - "OPTS=symbols STATS=compdbg,memdbg" - ] - } - EOJ - gcc=<<'EOJ' - { - "config": [ - "", - "CFLAGS=-DTCL_NO_DEPRECATED=1", - "--disable-shared", - "--disable-zipfs", - "--enable-symbols", - "--enable-symbols=mem", - "--enable-symbols=all" - ] - } - EOJ - EOF - ;; - *) - cat >>$GITHUB_OUTPUT <<'EOF' - msvc=<<'EOJ' - { - "config": [ - "", - "OPTS=symbols STATS=compdbg,memdbg" - ] - } - EOJ - gcc=<<'EOJ' - { - "config": [ - "", - "--disable-shared", - "--enable-symbols=all" - ] - } - EOJ - EOF - ;; - esac + ( + echo msvc=$(jq -nc '{config: (if env.IsMatched == "true" then env.MSVC_FULL else env.MSVC_PARTIAL end) | fromjson }' ) + echo gcc=$(jq -nc '{config: (if env.IsMatched == "true" then env.GCC_FULL else env.GCC_PARTIAL end) | fromjson }' ) + ) | tee -a $GITHUB_OUTPUT + env: + IsMatched: ${{ github.ref_name == 'main' || github.ref_name == 'core-9-0-branch' }} + # DO NOT CHANGE THESE MATRIX SPECS; IT AFFECTS OUR COST CONTROLS + MSVC_FULL: > + [ + "", + "CHECKS=nodep", + "OPTS=static", + "OPTS=noembed", + "OPTS=symbols", + "OPTS=symbols STATS=compdbg,memdbg" + ] + MSVC_PARTIAL: > + [ + "", + "OPTS=symbols STATS=compdbg,memdbg" + ] + GCC_FULL: > + [ + "", + "CFLAGS=-DTCL_NO_DEPRECATED=1", + "--disable-shared", + "--disable-zipfs", + "--enable-symbols", + "--enable-symbols=mem", + "--enable-symbols=all" + ] + GCC_PARTIAL: > + [ + "", + "--disable-shared", + "--enable-symbols=all" + ] msvc: runs-on: windows-2025 needs: plan -- cgit v0.12 From de6f149f5f44f1e7597657471daf43e23fdce51e Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 6 Jun 2025 13:33:10 +0000 Subject: fix silly capitalisation error --- .github/workflows/linux-build.yml | 2 +- .github/workflows/mac-build.yml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/linux-build.yml b/.github/workflows/linux-build.yml index 5194b81..9f79814 100644 --- a/.github/workflows/linux-build.yml +++ b/.github/workflows/linux-build.yml @@ -82,7 +82,7 @@ jobs: - name: Info run: | ulimit -a || echo 'get limit failed' - make runtest sCRIPT=../.github/workflows/info.tcl || echo 'get info failed' + make runtest SCRIPT=../.github/workflows/info.tcl || echo 'get info failed' - name: Run Tests run: | make test diff --git a/.github/workflows/mac-build.yml b/.github/workflows/mac-build.yml index dcb865d..00adcbf 100644 --- a/.github/workflows/mac-build.yml +++ b/.github/workflows/mac-build.yml @@ -96,7 +96,7 @@ jobs: - name: Info run: | ulimit -a || echo 'get limit failed' - make runtest sCRIPT=../.github/workflows/info.tcl || echo 'get info failed' + make runtest SCRIPT=../.github/workflows/info.tcl || echo 'get info failed' - name: Run Tests run: | make test -- cgit v0.12 From 326bfdff35e48b29c3ea779a5f9a72c1ebacc1e1 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 6 Jun 2025 13:54:51 +0000 Subject: give tests human-readable names --- tests/lseq.test | 2 +- tests/ooUtil.test | 2 +- tests/reg.test | 14 +++++++------- tests/socket.test | 2 +- tests/string.test | 4 ++-- 5 files changed, 12 insertions(+), 12 deletions(-) diff --git a/tests/lseq.test b/tests/lseq.test index f9a09f6..0d89683 100644 --- a/tests/lseq.test +++ b/tests/lseq.test @@ -1079,7 +1079,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/ooUtil.test b/tests/ooUtil.test index 20607b0..ec0fbe3 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/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/string.test b/tests/string.test index 27a78c1..6754508 100644 --- a/tests/string.test +++ b/tests/string.test @@ -1726,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 {repeate