ADDED .github/workflows/info.tcl Index: .github/workflows/info.tcl ================================================================== --- /dev/null +++ .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]] Index: .github/workflows/linux-build.yml ================================================================== --- .github/workflows/linux-build.yml +++ .github/workflows/linux-build.yml @@ -3,29 +3,51 @@ push: branches: - "main" - "core-9-0-branch" tags: - - "core-**" + - "core-*" permissions: contents: read jobs: + plan: + runs-on: ubuntu-latest + outputs: + gcc: ${{ steps.matrix.outputs.gcc }} + steps: + - name: Select build matrix based on branch name + id: matrix + run: | + ( + 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 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(needs.plan.outputs.gcc) }} defaults: run: shell: bash working-directory: unix steps: @@ -58,11 +80,11 @@ make -j4 tcltest timeout-minutes: 5 - 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 env: ERROR_ON_FAILURES: 1 @@ -70,12 +92,14 @@ - name: Test-Drive Installation run: | 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 Index: .github/workflows/mac-build.yml ================================================================== --- .github/workflows/mac-build.yml +++ .github/workflows/mac-build.yml @@ -3,14 +3,42 @@ push: branches: - "main" - "core-9-0-branch" tags: - - "core-**" + - "core-*" permissions: contents: read jobs: + plan: + runs-on: ubuntu-latest + outputs: + clang: ${{ steps.matrix.outputs.clang }} + steps: + - name: Select build matrix based on branch name + id: matrix + run: | + ( + 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: run: shell: bash @@ -34,19 +62,13 @@ ERROR_ON_FAILURES: 1 MAC_CI: 1 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(needs.plan.outputs.clang) }} defaults: run: shell: bash working-directory: unix steps: @@ -72,13 +94,13 @@ CFLAGS: -arch x86_64 -arch arm64 timeout-minutes: 15 - 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 env: ERROR_ON_FAILURES: 1 MAC_CI: 1 timeout-minutes: 15 Index: .github/workflows/onefiledist.yml ================================================================== --- .github/workflows/onefiledist.yml +++ .github/workflows/onefiledist.yml @@ -3,11 +3,11 @@ push: branches: - "main" - "core-9-0-branch" tags: - - "core-**" + - "core-*" permissions: contents: read jobs: linux: name: Linux @@ -70,11 +70,11 @@ path: create-dmg - name: Prepare 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 echo "CREATE_DMG=$(cd create-dmg;pwd)/create-dmg" >> $GITHUB_ENV echo "CFLAGS=-arch x86_64 -arch arm64" >> $GITHUB_ENV Index: .github/workflows/win-build.yml ================================================================== --- .github/workflows/win-build.yml +++ .github/workflows/win-build.yml @@ -3,31 +3,69 @@ push: branches: - "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.matrix.outputs.msvc }} + gcc: ${{ steps.matrix.outputs.gcc }} + steps: + - name: Select build matrix based on branch name + id: matrix + run: | + ( + 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 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 uses: actions/checkout@v4 timeout-minutes: 5 @@ -53,27 +91,21 @@ &nmake -f makefile.vc ${{ matrix.config }} test if ($lastexitcode -ne 0) { 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 + matrix: ${{ fromJson(needs.plan.outputs.gcc) }} steps: - name: Install MSYS2 uses: msys2/setup-msys2@v2 with: msystem: MINGW64 @@ -100,12 +132,14 @@ run: make -j4 tcltest timeout-minutes: 5 - 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 + 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. Index: .project ================================================================== --- .project +++ .project @@ -1,8 +1,8 @@ - tcl9 + tcl9.0 Index: README.md ================================================================== --- README.md +++ README.md @@ -1,8 +1,8 @@ # README: Tcl -This is the **Tcl 9.1a0** source distribution. +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.1 (in development, daily build) @@ -49,22 +49,22 @@ `license.terms` for complete information. ## 2. Documentation Extensive documentation is available on our website. The home page for this release, including new features, is -[here](https://www.tcl-lang.org/software/tcltk/9.1.html). +[here](https://www.tcl-lang.org/software/tcltk/9.0.html). Detailed release notes can be found at the [file distributions page](https://sourceforge.net/projects/tcl/files/Tcl/) by clicking on the relevant version. Information about Tcl itself can be found at the [Developer Xchange](https://www.tcl-lang.org/about/). There have been many Tcl books on the market. Many are mentioned in [the Wiki](https://wiki.tcl-lang.org/_/ref?N=25206). -The complete set of reference manual entries for Tcl 9.1 is [online, -here](https://www.tcl-lang.org/man/tcl9.1/). +The complete set of reference manual entries for Tcl 9.0 is [online, +here](https://www.tcl-lang.org/man/tcl9.0/). ### 2a. Unix Documentation The `doc` subdirectory in this release contains a complete set of reference manual entries for Tcl. Files with extension "`.1`" are for programs (for example, `tclsh.1`); files with extension "`.3`" are for C Index: changes.md ================================================================== --- changes.md +++ changes.md @@ -2,14 +2,220 @@ The source code for Tcl is managed by fossil. Tcl developers coordinate all changes to the Tcl source code at > [Tcl Source Code](https://core.tcl-lang.org/tcl/timeline) -Release Tcl 9.1a0 arises from the check-in with tag `core-9-1-a0`. +Release Tcl 9.0.2 arises from the check-in with tag `core-9-0-2`. + +Tcl patch releases have the primary purpose of delivering bug fixes +to the userbase. + +# New commands and options + - [New command encoding user](https://core.tcl-lang.org/tips/doc/trunk/tip/716.md) + - [New exec option -encoding](https://core.tcl-lang.org/tips/doc/trunk/tip/716.md) + +# Bug fixes + - [Better error-message than "interpreter uses an incompatible stubs mechanism"](https://core.tcl-lang.org/tcl/tktview/fc3509) + - [\[$interp eval $lambda\] after \[eval $lambda\] or vice versa fails](https://core.tcl-lang.org/tcl/tktview/67d5f7) + - [tcl::mathfunc::isunordered inconsistency with some integer values](https://core.tcl-lang.org/tcl/tktview/98006f) + - [test lseq hangs with -Os](https://core.tcl-lang.org/tcl/tktview/d2a3c5) + - [exec does not handle app execution aliases on Windows](https://core.tcl-lang.org/tcl/tktview/4f0b57) + - [auto_execok does not find several built-in cmd commands](https://core.tcl-lang.org/tcl/tktview/4e2c8b) + - [Panic "Buffer Underflow, BUFFER_PADDING not enough"](https://core.tcl-lang.org/tcl/tktview/73bb42) + - [MS-VS build system: pckIndex.tcl when building for 9 misses "t" for TCL 8.6 part](https://core.tcl-lang.org/tcl/tktview/a77029) + - [clock format -locale does not look up locale children if parent locale used first](https://core.tcl-lang.org/tcl/tktview/2c0f49) + - [Missing libtcl?.?.dll.a in Cygwin](https://core.tcl-lang.org/tcl/tktview/dcedba) + - [tclEpollNotfy PlatformEventsControl panics if websocket disconnected](https://core.tcl-lang.org/tcl/tktview/010d8f) + - [Tcl_InitStubs compatibility for 9.1](https://core.tcl-lang.org/tcl/tktview/fd8341) + - [proc with more than 2**31 variables](https://core.tcl-lang.org/tcl/tktview/92aeb8) + - [scan "long mantissa" %g](https://core.tcl-lang.org/tcl/tktview/42d14c) + - ["encoding system": wrong result without manifest](https://core.tcl-lang.org/tcl/tktview/8ffd8c) + - [lseq crash on out-of-range index](https://core.tcl-lang.org/tcl/tktview/7d3101) + - [lseq crash on nested indices](https://core.tcl-lang.org/tcl/tktview/452b10) + - [Build broken (trunk branch) tclCompExpr.c tclOOCall.c](https://core.tcl-lang.org/tcl/tktview/1dcda0) + - [Memory allocation runaway on truncated iso2022 encoding](https://core.tcl-lang.org/tcl/tktview/7346adc50) + - [Missing include dir for extensions in non-default locations](https://core.tcl-lang.org/tcl/tktview/3335120320) + +# Incompatibilities + - [The ActiveCodePage element has been removed from the Windows executable manifest for tclsh](https://core.tcl-lang.org/tips/doc/trunk/tip/716.md) + +# Updated bundled packages, libraries, standards, data + - sqlite3 3.49.1 + - tzdata 2025b + +Release Tcl 9.0.1 arises from the check-in with tag `core-9-0-1`. + +Tcl patch releases have the primary purpose of delivering bug fixes +to the userbase. As the first patch release in the Tcl 9.0.\* series, +Tcl 9.0.1 also includes a small number of interface changes that complete +some incomplete features first delivered in Tcl 9.0.0. + +# Completed 9.0 Features and Interfaces + - [TIP 701 - Tcl_FSTildeExpand C API](https://core.tcl-lang.org/tips/doc/trunk/tip/701.md) + - [TIP 707 - ptrAndSize internal rep in Tcl_Obj](https://core.tcl-lang.org/tips/doc/trunk/tip/707.md) + - [Size modifiers j, q, z, t not implemented]( https://core.tcl-lang.org/tcl/info/c4f365) + +# Bug fixes + - [regression in tzdata, %z instead of offset TZ-name](https://core.tcl-lang.org/tcl/tktview/2c237b) + - [Tcl will not start properly if there is an init.tcl file in the current dir](https://core.tcl-lang.org/tcl/tktview/43c94f) + - [clock scan "24:00", ISO-8601 compatibility](https://core.tcl-lang.org/tcl/tktview/aee9f2) + - [Temporary folder with file "tcl9registry13.dll" remains after "exit"](https://core.tcl-lang.org/tcl/tktview/6ce3c0) + - [Wrong result by "lsearch -stride -subindices -inline -all"](https://core.tcl-lang.org/tcl/info/5a1aaa) + - [TIP 609 - required Tcl_ThreadAlert() skipped with nested event loop](https://core.tcl-lang.org/tcl/info/c7e4c4) + - [buffer overwrite for non-BMP characters in utf-16](https://core.tcl-lang.org/tcl/tktview/66da4d) + - [zipfs info on mountpoint of executable returns zero offset in field 4"](https://core.tcl-lang.org/tcl/info/aaa84f) + - [zlib-8.8, zlib-8.16 fail on Fedora 40, gcc 14.1.1](https://core.tcl-lang.org/tcl/tktview/73d5cb) + - [install registry and dde in $INSTALL_DIR\lib always](https://core.tcl-lang.org/tcl/tktview/364bd9) + - [cannot build .chm help file (Windows)](https://core.tcl-lang.org/tcl/tktview/bb110c) + +# Incompatibilities + - No known incompatibilities with the Tcl 9.0.0 public interface. + +# Updated bundled packages, libraries, standards, data + - Itcl 4.3.2 + - sqlite3 3.47.2 + - Thread 3.0.1 + - TDBC\* 1.1.10 + - tcltest 2.5.9 + - tzdata 2024b, corrected + +Release Tcl 9.0.0 arises from the check-in with tag `core-9-0-0`. -Highlighted differences between Tcl 9.1 and Tcl 9.0 are summarized below, +Highlighted differences between Tcl 9.0 and Tcl 8.6 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) +# 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) Index: doc/Hash.3 ================================================================== --- doc/Hash.3 +++ doc/Hash.3 @@ -274,11 +274,11 @@ .PP The \fIhashKeyProc\fR member contains the address of a function called to calculate a hash value for the key. .PP .CS -typedef size_t \fBTcl_HashKeyProc\fR( +typedef TCL_HASH_TYPE \fBTcl_HashKeyProc\fR( Tcl_HashTable *\fItablePtr\fR, void *\fIkeyPtr\fR); .CE .PP If this is NULL then \fIkeyPtr\fR is used and Index: doc/Limit.3 ================================================================== --- doc/Limit.3 +++ doc/Limit.3 @@ -30,11 +30,11 @@ .sp \fBTcl_LimitTypeSet\fR(\fIinterp, type\fR) .sp \fBTcl_LimitTypeReset\fR(\fIinterp, type\fR) .sp -Tcl_Size +int \fBTcl_LimitGetCommands\fR(\fIinterp\fR) .sp \fBTcl_LimitSetCommands\fR(\fIinterp, commandLimit\fR) .sp \fBTcl_LimitGetTime\fR(\fIinterp, timeLimitPtr\fR) Index: doc/Object.3 ================================================================== --- doc/Object.3 +++ doc/Object.3 @@ -26,11 +26,11 @@ \fBTcl_BounceRefCount\fR(\fIobjPtr\fR) .sp 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 .AP Tcl_Obj *objPtr in Points to a value; Index: doc/ObjectType.3 ================================================================== --- doc/ObjectType.3 +++ doc/ObjectType.3 @@ -125,10 +125,21 @@ the string rep will be truncated to a length of \fInumBytes\fR bytes. When \fInumBytes\fR is greater than zero, and the returned pointer is \fINULL\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_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 depending on whether or not it is a pure value. Index: doc/StringObj.3 ================================================================== --- doc/StringObj.3 +++ doc/StringObj.3 @@ -6,11 +6,11 @@ '\" .TH Tcl_StringObj 3 8.1 Tcl "Tcl Library Procedures" .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, Tcl_IsEmpty \- 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 \- manipulate Tcl values as strings .SH SYNOPSIS .nf \fB#include \fR .sp Tcl_Obj * @@ -79,13 +79,10 @@ int \fBTcl_AttemptSetObjLength\fR(\fIobjPtr, newLength\fR) .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 .AP "const char" *bytes in Points to the first byte of an array of UTF-8-encoded bytes @@ -404,17 +401,10 @@ result. If an element of the \fIobjv\fR array consists of nothing but white space, then that value is ignored entirely. This white-space removal was added to make the output of the \fBconcat\fR command cleaner-looking. \fBTcl_ConcatObj\fR returns a pointer to a newly-created value whose ref count is zero. -.PP -The \fBTcl_IsEmpty\fR function returns 1 if \fIobjPtr\fR is the empty -string, 0 otherwise. -It doesn't generate the string representation (unless there -is no other way to do it), so it can safely be called on lists with -billions of elements, or any other data structure for which -it is impossible or expensive to construct the string representation. .SH "REFERENCE COUNT MANAGEMENT" .PP \fBTcl_NewStringObj\fR, \fBTcl_NewUnicodeObj\fR, \fBTcl_Format\fR, \fBTcl_ObjPrintf\fR, and \fBTcl_ConcatObj\fR always return a zero-reference object, much like \fBTcl_NewObj\fR. Index: doc/encoding.n ================================================================== --- doc/encoding.n +++ doc/encoding.n @@ -102,10 +102,18 @@ \fBencoding system\fR ?\fIencoding\fR? . 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 .VS TIP656 Operations involving encoding transforms may encounter several types of Index: doc/exec.n ================================================================== --- doc/exec.n +++ doc/exec.n @@ -29,10 +29,16 @@ .PP If the initial arguments to \fBexec\fR start with \fB\-\fR then they are treated as command-line switches and are not part of the pipeline specification. The following switches are currently supported: +.\" OPTION: -encoding +.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 Index: doc/lseq.n ================================================================== --- doc/lseq.n +++ doc/lseq.n @@ -17,11 +17,12 @@ \fBlseq \fIcount\fR ?\fBby \fIstep\fR? .fi .BE .SH DESCRIPTION .PP -The \fBlseq\fR command creates a sequence of numeric values using the given +The \fBlseq\fR command creates a sequence of numeric values, which may +be either wide integers or doubles, using the given parameters \fIstart\fR, \fIend\fR, and \fIstep\fR. The \fIoperation\fR argument "\fB..\fR" or "\fBto\fR" defines the range. The "\fBcount\fR" option is used to define a count of the number of elements in the list. A short form use of the command, with a single count value, will create a range from 0 to \fIcount\fR-1. @@ -39,10 +40,13 @@ % \fBlseq\fR 1 to 5 ;# increasing \fI\(-> 1 2 3 4 5 % \fBlseq\fR 5 to 1 ;# decreasing \fI\(-> 5 4 3 2 1 + +% \fBlseq\fR 0 0.5 by 0.1 ;# doubles +\fI\(-> 0.0 0.1 0.2 0.3 0.4 0.5\fR % \fBlseq\fR 6 to 1 by 2 ;# decreasing, step wrong sign, empty list % \fBlseq\fR 1 to 5 by 0 ;# all step sizes of 0 produce an empty list .\" Index: doc/registry.n ================================================================== --- doc/registry.n +++ doc/registry.n @@ -11,11 +11,11 @@ '\" Note: do not modify the .SH NAME line immediately below! .SH NAME registry \- Manipulate the Windows registry .SH SYNOPSIS .nf -\fBpackage require registry 1.4\fR +\fBpackage require registry 1.3\fR \fBregistry \fR?\fI\-mode\fR? \fIoption keyName\fR ?\fIarg arg ...\fR? .fi .BE .SH DESCRIPTION Index: doc/tclvars.n ================================================================== --- doc/tclvars.n +++ doc/tclvars.n @@ -328,13 +328,10 @@ Either \fBwindows\fR, or \fBunix\fR. This identifies the general operating environment of the machine. .IP \fBpointerSize\fR This gives the size of the native-machine pointer in bytes (strictly, it is same as the result of evaluating \fIsizeof(void*)\fR in C.) -.IP \fBthreaded\fR -If this variable exists, then the interpreter -was compiled with threads enabled. .IP \fBuser\fR This identifies the current user based on the login information available on the platform. This value comes from the getuid() and getpwuid() system calls on Unix, and the value from the GetUserName() system call on Windows. Index: generic/tcl.decls ================================================================== --- generic/tcl.decls +++ generic/tcl.decls @@ -38,26 +38,26 @@ } declare 2 { TCL_NORETURN void Tcl_Panic(const char *format, ...) } declare 3 { - void *Tcl_Alloc(size_t size) + void *Tcl_Alloc(TCL_HASH_TYPE size) } declare 4 { void Tcl_Free(void *ptr) } declare 5 { - void *Tcl_Realloc(void *ptr, size_t size) + void *Tcl_Realloc(void *ptr, TCL_HASH_TYPE size) } declare 6 { - void *Tcl_DbCkalloc(size_t size, const char *file, int line) + void *Tcl_DbCkalloc(TCL_HASH_TYPE 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, size_t size, + void *Tcl_DbCkrealloc(void *ptr, TCL_HASH_TYPE size, const char *file, int line) } # Tcl_CreateFileHandler and Tcl_DeleteFileHandler are only available on Unix, # but they are part of the old generic interface, so we include them here for @@ -127,10 +127,21 @@ Tcl_Obj *Tcl_DuplicateObj(Tcl_Obj *objPtr) } 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) } declare 35 { int Tcl_GetDoubleFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, @@ -246,10 +257,14 @@ void *clientData) } 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) } declare 83 { char *Tcl_Concat(Tcl_Size argc, const char *const *argv) @@ -1200,11 +1215,11 @@ declare 392 { void Tcl_MutexFinalize(Tcl_Mutex *mutex) } declare 393 { int Tcl_CreateThread(Tcl_ThreadId *idPtr, Tcl_ThreadCreateProc *proc, - void *clientData, size_t stackSize, int flags) + void *clientData, TCL_HASH_TYPE stackSize, int flags) } # Introduced in 8.3.2 declare 394 { Tcl_Size Tcl_ReadRaw(Tcl_Channel chan, char *dst, Tcl_Size bytesToRead) @@ -1286,10 +1301,14 @@ void Tcl_ClearChannelHandlers(Tcl_Channel channel) } 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) } declare 424 { @@ -1307,20 +1326,20 @@ declare 427 { void Tcl_UntraceCommand(Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *proc, void *clientData) } declare 428 { - void *Tcl_AttemptAlloc(size_t size) + void *Tcl_AttemptAlloc(TCL_HASH_TYPE size) } declare 429 { - void *Tcl_AttemptDbCkalloc(size_t size, const char *file, int line) + void *Tcl_AttemptDbCkalloc(TCL_HASH_TYPE size, const char *file, int line) } declare 430 { - void *Tcl_AttemptRealloc(void *ptr, size_t size) + void *Tcl_AttemptRealloc(void *ptr, TCL_HASH_TYPE size) } declare 431 { - void *Tcl_AttemptDbCkrealloc(void *ptr, size_t size, + void *Tcl_AttemptDbCkrealloc(void *ptr, TCL_HASH_TYPE size, const char *file, int line) } declare 432 { int Tcl_AttemptSetObjLength(Tcl_Obj *objPtr, Tcl_Size length) } @@ -1687,11 +1706,11 @@ } declare 531 { void Tcl_LimitTypeReset(Tcl_Interp *interp, int type) } declare 532 { - Tcl_Size Tcl_LimitGetCommands(Tcl_Interp *interp) + int Tcl_LimitGetCommands(Tcl_Interp *interp) } declare 533 { void Tcl_LimitGetTime(Tcl_Interp *interp, Tcl_Time *timeLimitPtr) } declare 534 { @@ -2127,11 +2146,11 @@ declare 636 { void Tcl_FreeInternalRep(Tcl_Obj *objPtr) } declare 637 { char *Tcl_InitStringRep(Tcl_Obj *objPtr, const char *bytes, - size_t numBytes) + TCL_HASH_TYPE numBytes) } declare 638 { Tcl_ObjInternalRep *Tcl_FetchInternalRep(Tcl_Obj *objPtr, const Tcl_ObjType *typePtr) } declare 639 { @@ -2361,16 +2380,10 @@ } # ----- 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) } ############################################################################## Index: generic/tcl.h ================================================================== --- generic/tcl.h +++ generic/tcl.h @@ -47,19 +47,18 @@ */ #if !defined(TCL_MAJOR_VERSION) # define TCL_MAJOR_VERSION 9 #endif -#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 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 defined(RC_INVOKED) /* * Utility macros: STRINGIFY takes an argument and wraps it in "" (double * quotation marks), JOIN joins two arguments. @@ -320,16 +319,34 @@ #define Tcl_WideAsLong(val) ((long)((Tcl_WideInt)(val))) #define Tcl_LongAsWide(val) ((Tcl_WideInt)((long)(val))) #define Tcl_WideAsDouble(val) ((double)((Tcl_WideInt)(val))) #define Tcl_DoubleAsWide(val) ((Tcl_WideInt)((double)(val))) -typedef ptrdiff_t Tcl_Size; -#define TCL_SIZE_MAX ((Tcl_Size)(((size_t)-1)>>1)) -#define TCL_SIZE_MODIFIER TCL_T_MODIFIER +#if TCL_MAJOR_VERSION < 9 +# ifndef Tcl_Size + typedef int Tcl_Size; +# endif +# ifndef TCL_SIZE_MAX +# define TCL_SIZE_MAX ((int)(((unsigned int)-1)>>1)) +# endif +# ifndef TCL_SIZE_MODIFIER +# define TCL_SIZE_MODIFIER "" +#endif +#else + typedef ptrdiff_t Tcl_Size; +# define TCL_SIZE_MAX ((Tcl_Size)(((size_t)-1)>>1)) +# define TCL_SIZE_MODIFIER TCL_T_MODIFIER +#endif /* TCL_MAJOR_VERSION */ #ifdef _WIN32 - typedef struct __stat64 Tcl_StatBuf; +# 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 #elif defined(__CYGWIN__) typedef struct { unsigned st_dev; unsigned short st_ino; unsigned short st_mode; @@ -406,11 +423,11 @@ /* * Definition of values for default stacksize and the possible flags to be * 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. */ /* @@ -450,22 +467,32 @@ * relative to the start of the match string, not the beginning of the entire * string. */ 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; /* * Picky compilers complain if this typdef doesn't appear before the struct's * reference in tclDecls.h. @@ -560,10 +587,11 @@ typedef void (Tcl_InterpDeleteProc) (void *clientData, Tcl_Interp *interp); 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, Tcl_Size level, const char *command, Tcl_Command commandInfo, Tcl_Size objc, struct Tcl_Obj *const *objv); @@ -570,10 +598,15 @@ typedef void (Tcl_FreeProc) (void *blockPtr); #define Tcl_ExitProc Tcl_FreeProc #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, ...); typedef void (Tcl_TcpAcceptProc) (void *callbackData, Tcl_Channel chan, char *address, int port); @@ -638,10 +671,11 @@ * type's internal representation. */ Tcl_SetFromAnyProc *setFromAnyProc; /* 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 */ Tcl_ObjTypeLengthProc *lengthProc; /* Return the [llength] of the AbstractList */ @@ -661,27 +695,34 @@ /* Replace sublist with another sublist */ Tcl_ObjTypeInOperatorProc *inOperProc; /* "in" and "ni" expr list operation. * Determine if the given string value matches * an element in the list. */ +#endif } Tcl_ObjType; -#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 */ +#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 /* * The following structure stores an internal representation (internalrep) for * a Tcl value. An internalrep is associated with an Tcl_ObjType when both * are stored in the same Tcl_Obj. The routines of the Tcl_ObjType govern * 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, */ /* not used internally any more. */ Tcl_WideInt wideValue; /* - an integer value >= 64bits */ @@ -914,11 +955,15 @@ /* * Flags that may be passed to Tcl_UniCharToUtf. * TCL_COMBINE Combine surrogates */ -#define TCL_COMBINE 0x1000000 +#if TCL_MAJOR_VERSION > 8 +# define TCL_COMBINE 0x1000000 +#else +# define TCL_COMBINE 0 +#endif /* *---------------------------------------------------------------------------- * Flag values passed to Tcl_RecordAndEval, Tcl_EvalObj, Tcl_EvalObjv. * WARNING: these bit choices must not conflict with the bit choices for * evalFlag bits in tclInt.h! @@ -1019,18 +1064,22 @@ *---------------------------------------------------------------------------- * Forward declarations of Tcl_HashTable and related types. */ #ifndef TCL_HASH_TYPE -# define TCL_HASH_TYPE size_t +#if TCL_MAJOR_VERSION > 8 +# define TCL_HASH_TYPE size_t +#else +# define TCL_HASH_TYPE unsigned +#endif #endif typedef struct Tcl_HashKeyType Tcl_HashKeyType; typedef struct Tcl_HashTable Tcl_HashTable; typedef struct Tcl_HashEntry Tcl_HashEntry; -typedef size_t (Tcl_HashKeyProc) (Tcl_HashTable *tablePtr, void *keyPtr); +typedef TCL_HASH_TYPE (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); typedef void (Tcl_FreeHashEntryProc) (Tcl_HashEntry *hPtr); @@ -1144,14 +1193,19 @@ * **bucketPtr. */ Tcl_Size numEntries; /* Total number of entries present in * table. */ Tcl_Size rebuildSize; /* Enlarge table when numEntries gets to be * this large. */ +#if TCL_MAJOR_VERSION > 8 size_t mask; /* Mask value used in hashing function. */ +#endif int downShift; /* Shift count used in hashing function. * Designed to use high-order bits of * randomized keys. */ +#if TCL_MAJOR_VERSION < 9 + int mask; /* Mask value used in hashing function. */ +#endif int keyType; /* Type of keys used in this table. It's * either TCL_CUSTOM_KEYS, TCL_STRING_KEYS, * TCL_ONE_WORD_KEYS, or an integer giving the * number of ints that is the size of the * key. */ @@ -1209,11 +1263,11 @@ */ typedef struct { void *next; /* Search position for underlying hash * table. */ - size_t epoch; /* Epoch marker for dictionary being searched, + TCL_HASH_TYPE epoch; /* Epoch marker for dictionary being searched, * or 0 if search has terminated. */ Tcl_Dict dictionaryPtr; /* Reference to dictionary being searched. */ } Tcl_DictSearch; /* @@ -1265,12 +1319,16 @@ * absolute time (the number of seconds from the epoch) or as an elapsed time. * On Unix systems the epoch is Midnight Jan 1, 1970 GMT. */ typedef struct Tcl_Time { +#if TCL_MAJOR_VERSION > 8 long long sec; /* Seconds. */ -#if defined(_CYGWIN_) +#else + long sec; /* Seconds. */ +#endif +#if defined(_CYGWIN_) && TCL_MAJOR_VERSION > 8 int usec; /* Microseconds. */ #else long usec; /* Microseconds. */ #endif } Tcl_Time; @@ -1317,11 +1375,15 @@ /* * Value to use as the closeProc for a channel that supports the close2Proc * interface. */ -#define TCL_CLOSE2PROC NULL +#if TCL_MAJOR_VERSION > 8 +# define TCL_CLOSE2PROC NULL +#else +# define TCL_CLOSE2PROC ((void *) 1) +#endif /* * Channel version tag. This was introduced in 8.3.2/8.4. */ @@ -1865,14 +1927,16 @@ Tcl_Size numTokens; /* Total number of tokens in command. */ Tcl_Size tokensAvailable; /* Total number of tokens available at * *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. * They should not be used by functions that invoke Tcl_ParseCommand. */ @@ -1887,10 +1951,13 @@ * terminated most recent token. Filled in by * ParseTokens. If an error occurs, points to * 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 * most commands; dynamic space is allocated * for very large commands that don't fit @@ -1967,21 +2034,25 @@ * when adding bits. */ #define TCL_ENCODING_START 0x01 #define TCL_ENCODING_END 0x02 -#define TCL_ENCODING_STOPONERROR 0x0 /* Not used any more */ +#if TCL_MAJOR_VERSION > 8 +# define TCL_ENCODING_STOPONERROR 0x0 /* Not used any more */ +#else +# define TCL_ENCODING_STOPONERROR 0x04 +#endif #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 */ #define TCL_ENCODING_INTERNAL_USE_MASK 0xFF00 /* * Reserve top byte for profile values (disjoint, not a mask). In case of * changes, ensure ENCODING_PROFILE_* macros in tclInt.h are modified if * necessary. */ -#define TCL_ENCODING_PROFILE_STRICT 0x00000000 +#define TCL_ENCODING_PROFILE_STRICT TCL_ENCODING_STOPONERROR #define TCL_ENCODING_PROFILE_TCL8 0x01000000 #define TCL_ENCODING_PROFILE_REPLACE 0x02000000 /* * The following definitions are the error codes returned by the conversion @@ -2020,11 +2091,15 @@ * then Tcl_UniChar must be 2-bytes in size (UTF-16). Since Tcl 9.0, UCS-4 * mode is the default and recommended mode. */ #ifndef TCL_UTF_MAX -# define TCL_UTF_MAX 4 +# if defined(BUILD_tcl) || TCL_MAJOR_VERSION > 8 +# define TCL_UTF_MAX 4 +# else +# define TCL_UTF_MAX 3 +# endif #endif /* * This represents a Unicode character. Any changes to this should also be * reflected in regcustom.h. @@ -2069,11 +2144,15 @@ * Structure containing information about a limit handler to be called when a * command- or time-limit is exceeded by an interpreter. */ 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 /* *---------------------------------------------------------------------------- * We would like to provide an anonymous structure "mp_int" here, which is @@ -2226,11 +2305,15 @@ *---------------------------------------------------------------------------- * The following constant is used to test for older versions of Tcl in the * stubs tables. */ -#define TCL_STUB_MAGIC ((int) 0xFCA3BACB + (int) sizeof(void *)) +#if TCL_MAJOR_VERSION > 8 +# define TCL_STUB_MAGIC ((int) 0xFCA3BACB + (int) sizeof(void *)) +#else +# define TCL_STUB_MAGIC ((int) 0xFCA3BACF) +#endif /* * The following function is required to be defined in all stubs aware * extensions. The function is actually implemented in the stub library, not * the main Tcl library, although there is a trivial implementation in the @@ -2248,18 +2331,38 @@ #else # define Tcl_ConsolePanic ((Tcl_PanicProc *)NULL) #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 +#else # define Tcl_InitStubs(interp, version, exact) \ (Tcl_InitStubs)(interp, version, \ (exact)|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16), \ TCL_STUB_MAGIC) +#endif +#else +#if TCL_MAJOR_VERSION < 9 +# define Tcl_InitStubs(interp, version, exact) \ + Tcl_Panic(((void)interp, (void)version, \ + (void)exact, "Please define -DUSE_TCL_STUBS")) #else # define Tcl_InitStubs(interp, version, exact) \ Tcl_PkgInitStubsCheck(interp, version, \ (exact)|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16)) +#endif #endif /* * Public functions that are not accessible via the stubs table. * Tcl_GetMemoryInfo is needed for AOLserver. [Bug 1868171] @@ -2296,11 +2399,11 @@ #endif # define Tcl_MainEx Tcl_MainExW EXTERN TCL_NORETURN void Tcl_MainExW(Tcl_Size argc, wchar_t **argv, Tcl_AppInitProc *appInitProc, Tcl_Interp *interp); #endif -#if defined(USE_TCL_STUBS) +#if defined(USE_TCL_STUBS) && (TCL_MAJOR_VERSION > 8) #define Tcl_SetPanicProc(panicProc) \ TclInitStubTable(((const char *(*)(Tcl_PanicProc *))TclStubCall((void *)panicProc))(panicProc)) #define Tcl_InitSubsystems() \ TclInitStubTable(((const char *(*)(void))TclStubCall((void *)1))()) #define Tcl_FindExecutable(argv0) \ Index: generic/tclArithSeries.c ================================================================== --- generic/tclArithSeries.c +++ generic/tclArithSeries.c @@ -166,11 +166,11 @@ { double d; if (!dblRepPtr->base.len) { return dblRepPtr->start; } - d = dblRepPtr->start + ((double)(dblRepPtr->base.len-1) * dblRepPtr->step); + d = dblRepPtr->start + ((dblRepPtr->base.len-1) * dblRepPtr->step); return ArithRound(d, dblRepPtr->precision); } static inline Tcl_WideInt ArithSeriesEndInt( @@ -189,11 +189,11 @@ { ArithSeriesDbl *dblRepPtr = (ArithSeriesDbl *)arithSeriesRepPtr; assert(arithSeriesRepPtr->isDouble); double d = dblRepPtr->start; if (index) { - d += ((double)index * dblRepPtr->step); + d += (index * dblRepPtr->step); } return ArithRound(d, dblRepPtr->precision); } @@ -225,18 +225,19 @@ { void *ptr; 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); if (strchr(str, 'e') == NULL && strchr(str, 'E') == NULL) { str = strchr(str, '.'); - return (str ? (unsigned)strlen(str + 1) : 0); + return (str ? strlen(str + 1) : 0); } /* don't calculate precision for e-notation */ } /* no fraction for TCL_NUMBER_NAN, TCL_NUMBER_INT, TCL_NUMBER_BIG */ return 0; @@ -335,12 +336,14 @@ end -= start; /* * 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 */ return (iend / istep) + 1; } @@ -454,25 +457,65 @@ */ static Tcl_Obj * NewArithSeriesInt( Tcl_WideInt start, Tcl_WideInt step, - Tcl_WideInt len) -{ - Tcl_WideInt length; - Tcl_Obj *arithSeriesObj; - ArithSeriesInt *arithSeriesRepPtr; - - length = len>=0 ? len : -1; - if (length < 0) { - length = -1; - } + Tcl_WideInt length) +{ + Tcl_Obj *arithSeriesObj = NULL; + ArithSeriesInt *arithSeriesRepPtr; TclNewObj(arithSeriesObj); if (length <= 0) { + /* TODO - should negative lengths be an error? */ return arithSeriesObj; + } else if (length > 1) { + /* Check for numeric overflow. Not needed for single element lists */ + Tcl_WideUInt absoluteStep; + Tcl_WideInt numIntervals = length - 1; + /* + * The checks below can probably be condensed but it is very easy to + * either inadvertently use undefined C behavior or unintended type + * promotion. Separating the cases helps me think more clearly. + */ + if (step >= 0) { + absoluteStep = step; + } else if (step == WIDE_MIN) { + /* -step and abs(step) are both undefined behavior */ + absoluteStep = 1 + (Tcl_WideUInt)WIDE_MAX; + } else { + absoluteStep = -step; + } + /* First, step*number of intervals should not overflow */ + if ((UWIDE_MAX / absoluteStep) < (Tcl_WideUInt) numIntervals) { + goto invalid_range; + } + if (step > 0) { + /* + * Because of check above and UWIDE_MAX=2*WIDE_MAX+1, + * second term will not underflow a Tcl_WideInt + */ + if (start > (WIDE_MAX - (step * numIntervals))) { + goto invalid_range; + } + } else if (step == WIDE_MIN) { + if (numIntervals > 0 || start < 0) { + goto invalid_range; + } + } else if (step < 0) { + /* + * Because of check above and UWIDE_MAX=2*WIDE_MAX+1 and + * step != WIDE_MIN second term will not underflow a Tcl_WideInt. + * DON'T use absoluteStep here because of unsigned type promotion + */ + if (start < (WIDE_MIN + ((-step) * numIntervals))) { + goto invalid_range; + } + } else /* step == 0 */ { + /* TODO - step == 0 && length > 1 should be error? */ + } } arithSeriesRepPtr = (ArithSeriesInt *) Tcl_Alloc(sizeof(ArithSeriesInt)); arithSeriesRepPtr->base.len = length; arithSeriesRepPtr->base.elements = NULL; @@ -481,15 +524,17 @@ arithSeriesRepPtr->start = start; arithSeriesRepPtr->step = step; arithSeriesObj->internalRep.twoPtrValue.ptr1 = arithSeriesRepPtr; arithSeriesObj->internalRep.twoPtrValue.ptr2 = NULL; arithSeriesObj->typePtr = &arithSeriesType; - if (length > 0) { - Tcl_InvalidateStringRep(arithSeriesObj); - } + Tcl_InvalidateStringRep(arithSeriesObj); return arithSeriesObj; + +invalid_range: + Tcl_BounceRefCount(arithSeriesObj); + return NULL; } /* *---------------------------------------------------------------------- * @@ -624,17 +669,17 @@ * None. *---------------------------------------------------------------------- */ 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; Tcl_WideInt len = -1; Tcl_Obj *objPtr; @@ -710,17 +755,17 @@ } else { if (useDoubles) { // Compute precision based on given command argument values precision = maxObjPrecision(startObj, NULL, stepObj); - dend = dstart + (dstep * (double)(len-1)); + dend = dstart + (dstep * (len-1)); // Make computed end value match argument(s) precision dend = ArithRound(dend, precision); end = dend; } else { end = start + (step * (len - 1)); - dend = (double)end; + dend = end; } } /* * todo: check whether the boundary must be rather LIST_MAX, to be more @@ -736,11 +781,11 @@ } 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 + (double)(len - 1) * dstep; + double d = dstart + (len - 1) * dstep; if (isnan(d)) { const char *s = "domain error: argument not in valid range"; Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1)); Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", s, (char *)NULL); return NULL; @@ -753,10 +798,15 @@ objPtr = NewArithSeriesDbl(dstart, dstep, len, precision); } else { objPtr = NewArithSeriesInt(start, step, len); } + if (objPtr == NULL && interp) { + const char *description = "invalid arithmetic series parameter values"; + Tcl_SetResult(interp, description, TCL_STATIC); + Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", description, (char *)NULL); + } return objPtr; } /* *---------------------------------------------------------------------- @@ -871,15 +921,15 @@ *---------------------------------------------------------------------- */ 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; (void)interp; /* silence compiler */ @@ -1061,11 +1111,11 @@ * *---------------------------------------------------------------------- */ 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) { ArithSeries *arithSeriesRepPtr; Tcl_Obj *resultObj; @@ -1145,15 +1195,15 @@ UpdateStringOfArithSeries( Tcl_Obj *arithSeriesObjPtr) { 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; } /* * Pass 1: estimate space. @@ -1167,28 +1217,32 @@ } } else { 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 /* * Pass 2: generate the string repr. */ - p = Tcl_InitStringRep(arithSeriesObjPtr, NULL, bytlen); + 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); p += TclFormatInt(p, d); assert(p - arithSeriesObjPtr->bytes <= bytlen); @@ -1203,12 +1257,11 @@ p += strlen(p); assert(p - arithSeriesObjPtr->bytes <= bytlen); *p++ = ' '; } } - *(--p) = '\0'; - arithSeriesObjPtr->length = p - arithSeriesObjPtr->bytes; + (void) Tcl_InitStringRep(arithSeriesObjPtr, NULL, (--p - srep)); } /* *---------------------------------------------------------------------- * Index: generic/tclAssembly.c ================================================================== --- generic/tclAssembly.c +++ generic/tclAssembly.c @@ -220,13 +220,13 @@ * generation */ Tcl_Parse* parsePtr; /* Parse of the current line of source */ 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 */ int maxDepth; /* Maximum stack depth encountered */ int curCatchDepth; /* Current depth of catches */ @@ -1264,11 +1264,11 @@ /* First operand to the instruction */ const char* operand1; /* String rep of the operand */ 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 */ int status = TCL_ERROR; /* Return value from this function */ @@ -1961,11 +1961,11 @@ 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_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 */ Index: generic/tclAsync.c ================================================================== --- generic/tclAsync.c +++ generic/tclAsync.c @@ -28,19 +28,19 @@ struct AsyncHandler *nextPtr, *prevPtr; /* Next, previous in list of all handlers * 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- * specific data from outside the thread it is * 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 { int asyncReady; /* This is set to 1 whenever a handler becomes * ready and it is cleared to zero whenever @@ -140,11 +140,11 @@ 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); asyncPtr = (AsyncHandler*)Tcl_Alloc(sizeof(AsyncHandler)); @@ -188,11 +188,11 @@ *---------------------------------------------------------------------- */ void Tcl_AsyncMark( - Tcl_AsyncHandler async) /* Token for handler. */ + Tcl_AsyncHandler async) /* Token for handler. */ { AsyncHandler *token = (AsyncHandler *) async; Tcl_MutexLock(&asyncMutex); token->ready = 1; @@ -199,10 +199,11 @@ if (!token->originTsd->asyncActive) { token->originTsd->asyncReady = 1; Tcl_ThreadAlert(token->originThrdId); } Tcl_MutexUnlock(&asyncMutex); + } /* *---------------------------------------------------------------------- * @@ -221,12 +222,12 @@ *---------------------------------------------------------------------- */ 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; return TclAsyncNotifier(sigNumber, token->originThrdId, @@ -375,11 +376,11 @@ *---------------------------------------------------------------------- */ void Tcl_AsyncDelete( - Tcl_AsyncHandler async) /* Token for handler to delete. */ + Tcl_AsyncHandler async) /* Token for handler to delete. */ { AsyncHandler *asyncPtr = (AsyncHandler *) async; /* * Assure early handling of the constraint Index: generic/tclBasic.c ================================================================== --- generic/tclBasic.c +++ generic/tclBasic.c @@ -205,12 +205,12 @@ static Tcl_ObjCmdProc ExprSqrtFunc; static Tcl_ObjCmdProc ExprSrandFunc; static Tcl_ObjCmdProc ExprUnaryFunc; static Tcl_ObjCmdProc ExprWideFunc; static Tcl_ObjCmdProc FloatClassifyObjCmd; -static void MathFuncWrongNumArgs(Tcl_Interp *interp, Tcl_Size expected, - Tcl_Size actual, Tcl_Obj *const *objv); +static void MathFuncWrongNumArgs(Tcl_Interp *interp, int expected, + int actual, Tcl_Obj *const *objv); static Tcl_NRPostProc NRCoroutineCallerCallback; static Tcl_NRPostProc NRCoroutineExitCallback; static Tcl_NRPostProc NRCommand; static void ProcessUnexpectedResult(Tcl_Interp *interp, @@ -2715,13 +2715,13 @@ *---------------------------------------------------------------------- */ typedef struct { Tcl_ObjCmdProc2 *proc; - void *clientData; /* Arbitrary value to pass to proc function. */ + void *clientData; /* Arbitrary value to pass to proc function. */ Tcl_CmdDeleteProc *deleteProc; - void *deleteData; /* Arbitrary value to pass to deleteProc function. */ + void *deleteData; /* Arbitrary value to pass to deleteProc function. */ Tcl_ObjCmdProc2 *nreProc; } CmdWrapperInfo; static int cmdWrapperProc( @@ -3004,13 +3004,13 @@ *---------------------------------------------------------------------- */ 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; int i, result; const char **argv = (const char **) @@ -3548,10 +3548,11 @@ Tcl_Command command, /* Token for command returned by a previous * call to Tcl_CreateObjCommand. The command must * 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; char *name; @@ -3945,11 +3946,11 @@ *---------------------------------------------------------------------- */ 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. */ { CancelInfo *cancelInfo = (CancelInfo *)clientData; Interp *iPtr; @@ -4435,11 +4436,11 @@ void *data[], Tcl_Interp *interp, TCL_UNUSED(int) /*result*/) { Command *cmdPtr = NULL, *preCmdPtr = (Command *)data[0]; - int flags = (int)PTR2INT(data[1]); + int flags = PTR2INT(data[1]); Tcl_Size objc = PTR2INT(data[2]); Tcl_Obj **objv = (Tcl_Obj **)data[3]; Interp *iPtr = (Interp *) interp; Namespace *lookupNsPtr = NULL; int enterTracesDone = 0; @@ -4617,11 +4618,12 @@ TCL_DTRACE_CMD_ARGS(a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], a[8], a[9]); } 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]); TclDecrRefCount(info); } @@ -5177,11 +5179,11 @@ { Interp *iPtr = (Interp *) interp; const char *p, *next; const int minObjs = 20; Tcl_Obj **objv, **objvSpace; - char *expand; + int *expand; Tcl_Size *lines, *lineSpace; Tcl_Token *tokenPtr; int expandRequested, code = TCL_OK; Tcl_Size bytesLeft, commandLength; CallFrame *savedVarFramePtr;/* Saves old copy of iPtr->varFramePtr in case @@ -5194,11 +5196,11 @@ * the script, so that it can be freed * properly if an error occurs. */ 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 *)); - char *expandStack = (char *)TclStackAlloc(interp, minObjs * sizeof(char)); + int *expandStack = (int *)TclStackAlloc(interp, minObjs * sizeof(int)); Tcl_Size *linesStack = (Tcl_Size *)TclStackAlloc(interp, minObjs * sizeof(Tcl_Size)); /* TIP #280 Structures for tracking of command * locations. */ Tcl_Size *clNext = NULL; /* Pointer for the tracking of invisible * continuation lines. Initialized only if the @@ -5331,11 +5333,11 @@ /* * Generate an array of objects for the words of the command. */ if (numWords > minObjs) { - expand = (char *)Tcl_Alloc(numWords * sizeof(char)); + expand = (int *)Tcl_Alloc(numWords * sizeof(int)); objvSpace = (Tcl_Obj **) Tcl_Alloc(numWords * sizeof(Tcl_Obj *)); lineSpace = (Tcl_Size *) Tcl_Alloc(numWords * sizeof(Tcl_Size)); } @@ -6291,11 +6293,11 @@ int result) { Interp *iPtr = (Interp *) interp; CallFrame *savedVarFramePtr = (CallFrame *)data[0]; Tcl_Obj *objPtr = (Tcl_Obj *)data[1]; - int allowExceptions = (int)PTR2INT(data[2]); + int allowExceptions = PTR2INT(data[2]); if (iPtr->numLevels == 0) { if (result == TCL_RETURN) { result = TclUpdateReturnInfo(iPtr); } @@ -6545,11 +6547,11 @@ if (Tcl_InitBignumFromDouble(interp, d, &big) != TCL_OK) { return TCL_ERROR; } resultPtr = Tcl_NewBignumObj(&big); } - /* FALLTHRU */ + TCL_FALLTHROUGH(); case TCL_NUMBER_INT: case TCL_NUMBER_BIG: result = TclGetLongFromObj(interp, resultPtr, ptr); break; @@ -7768,11 +7770,11 @@ /* * Since the recurrence keeps seed values in the range [1, RAND_IM - 1], * dividing by RAND_IM yields a double in the range (0, 1). */ - dResult = (double)iPtr->randSeed * (1.0/RAND_IM); + dResult = iPtr->randSeed * (1.0/RAND_IM); /* * Push a Tcl object with the result. */ @@ -8085,11 +8087,11 @@ DoubleObjIsClass( Tcl_Interp *interp, 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; if (objc != 2) { MathFuncWrongNumArgs(interp, 2, objc, objv); @@ -8176,12 +8178,14 @@ if (objc != 3) { MathFuncWrongNumArgs(interp, 3, objc, objv); 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; } dCls = ((dCls == FP_NAN) || (dCls2 == FP_NAN)) ? 1 : 0; Tcl_SetObjResult(interp, ((Interp *)interp)->execEnvPtr->constants[dCls]); @@ -8258,12 +8262,12 @@ */ static void MathFuncWrongNumArgs( Tcl_Interp *interp, /* Tcl interpreter */ - Tcl_Size expected, /* Formal parameter count. */ - Tcl_Size found, /* Actual parameter count. */ + int expected, /* Formal parameter count. */ + int found, /* Actual parameter count. */ Tcl_Obj *const *objv) /* Actual parameter vector. */ { const char *name = TclGetString(objv[0]); const char *tail = name + strlen(name); @@ -9611,11 +9615,11 @@ 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; } - /* fallthrough */ + TCL_FALLTHROUGH(); case COROUTINE_ARGUMENTS_ARBITRARY: if (objc > 1) { Tcl_SetObjResult(interp, Tcl_NewListObj(objc - 1, objv + 1)); } break; Index: generic/tclBinary.c ================================================================== --- generic/tclBinary.c +++ generic/tclBinary.c @@ -510,11 +510,11 @@ const char *srcEnd = src + length; int proper = 1; for (; src < srcEnd && dst < dstEnd; ) { int ch; - Tcl_Size count = TclUtfToUniChar(src, &ch); + int count = TclUtfToUniChar(src, &ch); if (ch > 255) { proper = 0; if (demandProper) { if (interp) { @@ -2503,10 +2503,12 @@ } switch (index) { case OPT_STRICT: strict = 1; break; + default: + TCL_UNREACHABLE(); } } TclNewObj(resultObj); data = Tcl_GetBytesFromObj(NULL, objv[objc - 1], &count); @@ -2647,10 +2649,12 @@ if (wrapchar == NULL) { purewrap = 0; wrapchar = TclGetStringFromObj(objv[i + 1], &wrapcharlen); } break; + default: + TCL_UNREACHABLE(); } } if (wrapcharlen == 0) { maxlen = 0; } @@ -2663,11 +2667,11 @@ if (count > 0) { unsigned char *cursor = NULL; size = (((count * 4) / 3) + 3) & ~3; /* ensure 4 byte chunks */ if (maxlen > 0 && size > maxlen) { - Tcl_Size adjusted = size + (wrapcharlen * (size / maxlen)); + int adjusted = size + (wrapcharlen * (size / maxlen)); if (size % maxlen == 0) { adjusted -= wrapcharlen; } size = adjusted; @@ -2771,40 +2775,40 @@ lineLength = ((lineLength - 1) & -4) + 1; /* 5, 9, 13 ... */ break; 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(); } } /* * Allocate the buffer. This is a little bit too long, but is "good @@ -2907,10 +2911,12 @@ } switch (index) { case OPT_STRICT: strict = 1; break; + default: + TCL_UNREACHABLE(); } } TclNewObj(resultObj); data = Tcl_GetBytesFromObj(NULL, objv[objc - 1], &count); @@ -2970,18 +2976,18 @@ /* * Translate that grouping into (up to) three binary bytes output. */ if (lineLen > 0) { - *cursor++ = (unsigned char)(((d[0] - 0x20) & 0x3F) << 2) + *cursor++ = (((d[0] - 0x20) & 0x3F) << 2) | (((d[1] - 0x20) & 0x3F) >> 4); if (--lineLen > 0) { - *cursor++ = (unsigned char)(((d[1] - 0x20) & 0x3F) << 4) + *cursor++ = (((d[1] - 0x20) & 0x3F) << 4) | (((d[2] - 0x20) & 0x3F) >> 2); if (--lineLen > 0) { - *cursor++ = (unsigned char)((((d[2] - 0x20) & 0x3F) << 6) - | (((d[3] - 0x20) & 0x3F))); + *cursor++ = (((d[2] - 0x20) & 0x3F) << 6) + | (((d[3] - 0x20) & 0x3F)); lineLen--; } } } @@ -3082,10 +3088,12 @@ } switch (index) { case OPT_STRICT: strict = 1; break; + default: + TCL_UNREACHABLE(); } } TclNewObj(resultObj); data = Tcl_GetBytesFromObj(NULL, objv[objc - 1], &count); Index: generic/tclCkalloc.c ================================================================== --- generic/tclCkalloc.c +++ generic/tclCkalloc.c @@ -274,10 +274,11 @@ if (nukeGuards) { memset(memHeaderP->low_guard, 0, LOW_GUARD_SIZE); memset(hiPtr, 0, HIGH_GUARD_SIZE); } + } /* *---------------------------------------------------------------------- * Index: generic/tclClock.c ================================================================== --- generic/tclClock.c +++ generic/tclClock.c @@ -1152,10 +1152,12 @@ if (Tcl_SetEnsembleFlags(interp, token, ensFlags) != TCL_OK) { return TCL_ERROR; } break; } + default: + TCL_UNREACHABLE(); } } return TCL_OK; } @@ -3157,10 +3159,12 @@ #endif break; case CLICKS_MICROS: clicks = TclpGetMicroseconds(); break; + default: + TCL_UNREACHABLE(); } Tcl_SetObjResult(interp, Tcl_NewWideIntObj(clicks)); return TCL_OK; } @@ -3369,10 +3373,12 @@ } else { opts->flags &= ~CLF_VALIDATE; } } break; + default: + TCL_UNREACHABLE(); } saw |= 1 << optionIndex; } /* @@ -3429,12 +3435,12 @@ if (TclHasInternalRep(baseObj, &tclBignumType)) { goto baseOverflow; } 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; } /* * Seconds could be an unsigned number that overflowed. Make sure @@ -3622,11 +3628,12 @@ if (ret != TCL_OK) { goto done; } /* 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) { /* Use compiled version of FreeScan - */ @@ -4535,10 +4542,12 @@ yyRelSeconds += offs * 60; break; case CLC_ADD_SECONDS: yyRelSeconds += offs; break; + default: + TCL_UNREACHABLE(); } if (unitIndex < CLC_ADD_HOURS) { /* date units only */ info->flags |= CLF_RELCONV; } } @@ -4704,11 +4713,15 @@ #endif #define TZ_INIT_MARKER ((WCHAR *) INT2PTR(-1)) 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 */ } ClockTzStatic; static ClockTzStatic tz = { /* Global timezone info; protected by Index: generic/tclClockFmt.c ================================================================== --- generic/tclClockFmt.c +++ generic/tclClockFmt.c @@ -563,11 +563,14 @@ allocsize += size; if (size > sizeof(hPtr->key)) { allocsize -= sizeof(hPtr->key); } - fss = (ClockFmtScnStorage *)Tcl_Alloc(allocsize); + fss = (ClockFmtScnStorage *)Tcl_AttemptAlloc(allocsize); + if (!fss) { + return NULL; + } /* initialize */ memset(fss, 0, sizeof(*fss)); hPtr = HashEntry4FmtScn(fss); @@ -1022,11 +1025,11 @@ static const char * FindTokenBegin( const char *p, const char *end, - ClockScanToken *tok, + const ClockScanToken *tok, int flags) { if (p < end) { char c; @@ -1035,35 +1038,45 @@ case CTOKT_INT: case CTOKT_WIDE: 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; case CTOKT_WORD: c = *(tok->tokWord.start); 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; } } return p; @@ -1087,11 +1100,11 @@ static void DetermineGreedySearchLen( ClockFmtScnCmdArgs *opts, DateInfo *info, - ClockScanToken *tok, + const ClockScanToken *tok, int *minLenPtr, int *maxLenPtr) { int minLen = tok->map->minSize; int maxLen; @@ -1139,11 +1152,11 @@ } /* 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) */ end = p + tok->lookAhMax + yySpaceCount + 1; if (end > info->dateEnd) { @@ -1153,11 +1166,11 @@ if (laTok->map && p < end) { /* 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; } /* try again with fewer length */ @@ -1489,11 +1502,11 @@ } #endif static inline const char * FindWordEnd( - ClockScanToken *tok, + const ClockScanToken *tok, const char *p, const char *end) { const char *x = tok->tokWord.start; const char *pfnd = p; @@ -1514,11 +1527,11 @@ static int ClockScnToken_Month_Proc( ClockFmtScnCmdArgs *opts, DateInfo *info, - ClockScanToken *tok) + const ClockScanToken *tok) { #if 0 /* currently unused, test purposes only */ static const char * months[] = { /* full */ @@ -1564,11 +1577,11 @@ 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}; int ret, val; int minLen, maxLen; @@ -1638,11 +1651,11 @@ static int ClockScnToken_amPmInd_Proc( ClockFmtScnCmdArgs *opts, DateInfo *info, - ClockScanToken *tok) + const ClockScanToken *tok) { int ret, val; int minLen, maxLen; Tcl_Obj *amPmObj[2]; @@ -1671,11 +1684,11 @@ static int ClockScnToken_LocaleERA_Proc( ClockFmtScnCmdArgs *opts, DateInfo *info, - ClockScanToken *tok) + const ClockScanToken *tok) { ClockClientData *dataPtr = opts->dataPtr; int ret, val; int minLen, maxLen; @@ -1710,11 +1723,11 @@ static int ClockScnToken_LocaleListMatcher_Proc( ClockFmtScnCmdArgs *opts, DateInfo *info, - ClockScanToken *tok) + const ClockScanToken *tok) { int ret, val; int minLen, maxLen; TclStrIdxTree *idxTree; @@ -1741,11 +1754,11 @@ static int ClockScnToken_JDN_Proc( ClockFmtScnCmdArgs *opts, DateInfo *info, - ClockScanToken *tok) + const ClockScanToken *tok) { int minLen, maxLen; const char *p = yyInput, *end, *s; Tcl_WideInt intJD; int fractJD = 0, fractJDDiv = 1; @@ -1812,11 +1825,11 @@ static int ClockScnToken_TimeZone_Proc( ClockFmtScnCmdArgs *opts, DateInfo *info, - ClockScanToken *tok) + const ClockScanToken *tok) { int minLen, maxLen; int len = 0; const char *p = yyInput; Tcl_Obj *tzObjStor = NULL; @@ -1904,11 +1917,11 @@ static int ClockScnToken_StarDate_Proc( ClockFmtScnCmdArgs *opts, DateInfo *info, - ClockScanToken *tok) + const ClockScanToken *tok) { int minLen, maxLen; const char *p = yyInput, *end, *s; int year, fractYear, fractDayDiv, fractDay; static const char *stardatePref = "stardate "; @@ -2298,12 +2311,11 @@ /* next token */ AllocTokenInChain(tok, scnTok, fss->scnTokC, ClockScanToken *); tokCnt++; continue; } - word_tok: - { + word_tok: { /* try continue with previous word token */ ClockScanToken *wordTok = tok - 1; if (wordTok < scnTok || wordTok->map != &ScnWordTokenMap) { /* start with new word token */ @@ -2322,12 +2334,12 @@ if (wordTok == tok) { AllocTokenInChain(tok, scnTok, fss->scnTokC, ClockScanToken *); tokCnt++; } - } break; + } } } /* calculate end distance value for each tokens */ if (tok > scnTok) { @@ -2371,12 +2383,12 @@ DateInfo *info, /* Date fields used for parsing & converting */ Tcl_Obj *strObj, /* String containing the time to scan */ 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; int ret = TCL_ERROR; @@ -2552,10 +2564,12 @@ if (isspace(UCHAR(*x))) { yySpaceCount--; } p++; break; + default: + TCL_UNREACHABLE(); } } /* check end was reached */ if (p < end) { /* in non-strict mode bypass spaces at end of input */ @@ -2600,11 +2614,11 @@ /* dd precedence below ddd */ switch (flags & (CLF_MONTH|CLF_DAYOFYEAR|CLF_DAYOFMONTH)) { 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)) { flags &= ~CLF_ISO8601WEEK; } @@ -3341,12 +3355,11 @@ tokCnt++; p++; continue; } default: - word_tok: - { + word_tok: { /* try continue with previous word token */ ClockFormatToken *wordTok = tok - 1; if (wordTok < fmtTok || wordTok->map != &FmtWordTokenMap) { /* start with new word token */ @@ -3361,12 +3374,12 @@ if (wordTok == tok) { AllocTokenInChain(tok, fmtTok, fss->fmtTokC, ClockFormatToken *); tokCnt++; } - } break; + } } } /* correct count of real used tokens and free mem if desired * (1 is acceptable delta to prevent memory fragmentation) */ Index: generic/tclCmdAH.c ================================================================== --- generic/tclCmdAH.c +++ generic/tclCmdAH.c @@ -51,10 +51,11 @@ static Tcl_ObjCmdProc EncodingConverttoObjCmd; 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, struct ForeachState *statePtr); static int GetStatBuf(Tcl_Interp *interp, Tcl_Obj *pathPtr, @@ -392,10 +393,11 @@ {"convertto", EncodingConverttoObjCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0}, {"dirs", EncodingDirsObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1}, {"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} }; return TclMakeEnsemble(interp, "encoding", encodingImplMap); } @@ -481,10 +483,12 @@ } break; case FAILINDEX: failVarObj = objv[argIndex]; break; + default: + TCL_UNREACHABLE(); } } /* Get encoding after opts so no need to free it on option error */ if (Tcl_GetEncodingFromObj(interp, objv[objc - 2], &encoding) != TCL_OK) { return TCL_ERROR; @@ -522,11 +526,11 @@ Tcl_Obj *const objv[]) /* Argument objects. */ { 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; Tcl_Obj *failVarObj; Tcl_Size errorLocation; @@ -591,10 +595,11 @@ /* We're done with the encoding */ Tcl_FreeEncoding(encoding); return TCL_OK; + } /* *---------------------------------------------------------------------- * @@ -683,10 +688,11 @@ /* We're done with the encoding */ Tcl_FreeEncoding(encoding); return TCL_OK; + } /* *---------------------------------------------------------------------- * @@ -748,13 +754,13 @@ */ 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); return TCL_ERROR; } @@ -824,10 +830,40 @@ return Tcl_SetSystemEncoding(interp, TclGetString(objv[1])); } return TCL_OK; } +/* + *----------------------------------------------------------------------------- + * + * 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 -- * @@ -2116,12 +2152,11 @@ break; case TCL_PATH_VOLUME_RELATIVE: TclNewLiteralStringObj(typeName, "volumerelative"); break; default: - /* Should be unreachable */ - return TCL_OK; + TCL_UNREACHABLE(); } Tcl_SetObjResult(interp, typeName); return TCL_OK; } @@ -2926,10 +2961,11 @@ case TCL_ERROR: Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (\"%s\" body line %d)", (statePtr->resultList != NULL ? "lmap" : "foreach"), Tcl_GetErrorLine(interp))); + TCL_FALLTHROUGH(); default: goto done; } /* Index: generic/tclCmdIL.c ================================================================== --- generic/tclCmdIL.c +++ generic/tclCmdIL.c @@ -1257,11 +1257,11 @@ Tcl_Interp *interp, /* Current interpreter. */ CmdFrame *framePtr) /* Frame to get info for. */ { 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; /* * This array is indexed by the TCL_LOCATION_... values, except * for _LAST. @@ -2425,11 +2425,11 @@ 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; Tcl_Size len, index; int copied = 0, result; @@ -2518,12 +2518,13 @@ 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. * Otherwise set the interpreter's result object to be a list object. */ @@ -2554,11 +2555,12 @@ int 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; Tcl_Obj *objPtr; @@ -2602,11 +2604,12 @@ int 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; Tcl_Obj *elemPtr, *stored; Tcl_Obj *listPtr; @@ -2720,11 +2723,12 @@ int 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; if (objc != 4) { Tcl_WrongNumArgs(interp, 1, objv, "list first last"); @@ -2931,12 +2935,13 @@ int Tcl_LrepeatObjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* The argument objects. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) + /* The argument objects. */ { Tcl_WideInt elementCount, i; Tcl_Size totalElems; Tcl_Obj *listPtr, **dataArray = NULL; @@ -4030,15 +4035,15 @@ * pointer, numValuePtr reference count is incremented. */ 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; void *internalPtr; @@ -4078,11 +4083,12 @@ return ErrArg; } 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 */ *keywordIndexPtr = keyword; /* type of expression result */ return NumericArg; @@ -4126,13 +4132,13 @@ */ 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; Tcl_WideInt values[5]; Tcl_Obj *numValues[5]; @@ -5354,11 +5360,11 @@ int uniLeft = 0, uniRight = 0, uniLeftLower, uniRightLower; int diff, zeros; 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 * them as numbers, rather than strings. If one number has more * leading zeros than the other, the number with more leading Index: generic/tclCmdMZ.c ================================================================== --- generic/tclCmdMZ.c +++ generic/tclCmdMZ.c @@ -209,10 +209,12 @@ break; } case REGEXP_LAST: i++; goto endOfForLoop; + default: + TCL_UNREACHABLE(); } } endOfForLoop: if ((objc - i) < (2 - about)) { @@ -564,10 +566,12 @@ break; } case REGSUB_LAST: idx++; goto endOfForLoop; + default: + TCL_UNREACHABLE(); } } endOfForLoop: if (objc < idx + 3 || objc > idx + 4) { @@ -1578,10 +1582,12 @@ "?-strict? ?-failindex var? str"); return TCL_ERROR; } failVarObj = objv[++i]; break; + default: + TCL_UNREACHABLE(); } } } /* @@ -1875,10 +1881,12 @@ chcomp = Tcl_UniCharIsWordChar; break; case STR_IS_XDIGIT: chcomp = UniCharIsHexDigit; break; + default: + TCL_UNREACHABLE(); } if (chcomp != NULL) { string1 = TclGetStringFromObj(objPtr, &length1); if (length1 == 0) { @@ -4184,10 +4192,12 @@ case TMRT_CALIBRATE: calibrate = objv[i]; break; case TMRT_LAST: break; + default: + TCL_UNREACHABLE(); } } if (i >= objc || i < objc - 3) { usage: @@ -4408,11 +4418,11 @@ /* * Force stop immediately. */ threshold = 1; maxcnt = 0; - /* FALLTHRU */ + TCL_FALLTHROUGH(); case TCL_CONTINUE: result = TCL_OK; break; default: goto done; @@ -4497,11 +4507,12 @@ lastIterTm = lastTm > avgIterTm ? lastTm : avgIterTm; } else { lastIterTm = avgIterTm; } estIterTm *= lastIterTm; - last = middle; lastCount = count; + last = middle; + lastCount = count; /* * Calculate next threshold to check. * Firstly check iteration time is not larger than remaining time, * considering last known iteration growth factor. @@ -4834,10 +4845,12 @@ Tcl_ListObjAppendElement(NULL, handlersObj, Tcl_NewListObj(5, info)); haveHandlers = 1; i += 3; break; + default: + TCL_UNREACHABLE(); } } if (bodyShared) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "last non-finally clause must not have a body of \"-\"", -1)); @@ -5338,11 +5351,11 @@ * structure. Assumed to be valid. Assumed to * contain n elements. */ 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); const char *listHead = listStr; Tcl_Size i, length = strlen(listStr); Index: generic/tclCompCmds.c ================================================================== --- generic/tclCompCmds.c +++ generic/tclCompCmds.c @@ -2962,11 +2962,11 @@ *---------------------------------------------------------------------- */ static void * DupForeachInfo( - void *clientData) /* The foreach command's compilation auxiliary + void *clientData) /* The foreach command's compilation auxiliary * data to duplicate. */ { ForeachInfo *srcPtr = (ForeachInfo *)clientData; ForeachInfo *dupPtr; ForeachVarList *srcListPtr, *dupListPtr; @@ -3011,11 +3011,11 @@ *---------------------------------------------------------------------- */ static void FreeForeachInfo( - void *clientData) /* The foreach command's compilation auxiliary + void *clientData) /* The foreach command's compilation auxiliary * data to free. */ { ForeachInfo *infoPtr = (ForeachInfo *)clientData; ForeachVarList *listPtr; size_t i, numLists = infoPtr->numLists; @@ -3344,11 +3344,11 @@ j = 2; /* The index into the argument tokens, for * TIP#280 handling. */ 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 == '%') { Tcl_AppendToObj(tmpObj, start, bytes - start); if (*++bytes == '%') { Index: generic/tclCompCmdsGR.c ================================================================== --- generic/tclCompCmdsGR.c +++ generic/tclCompCmdsGR.c @@ -56,11 +56,11 @@ Tcl_Obj *tmpObj; int result = TCL_ERROR; TclNewObj(tmpObj); if (TclWordKnownAtCompileTime(tokenPtr, tmpObj)) { - result = TclIndexEncode(NULL, tmpObj, (int)before, (int)after, indexPtr); + result = TclIndexEncode(NULL, tmpObj, before, after, indexPtr); } Tcl_DecrRefCount(tmpObj); return result; } @@ -2199,10 +2199,11 @@ /* * The pattern is "**"! I believe that should be impossible, * but we definitely can't handle that at all. */ } + TCL_FALLTHROUGH(); case '\0': case '?': case '[': case '\\': goto done; } bytes++; } Index: generic/tclCompCmdsSZ.c ================================================================== --- generic/tclCompCmdsSZ.c +++ generic/tclCompCmdsSZ.c @@ -2113,11 +2113,11 @@ 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 + Tcl_Size *bodyLines, /* Array of line numbers for body list * items. */ Tcl_Size **bodyContLines) /* Array of continuation line info. */ { enum {Switch_Exact, Switch_Glob, Switch_Regexp}; int foundDefault; /* Flag to indicate whether a "default" clause @@ -2219,11 +2219,11 @@ } else { OP1(STR_MATCH, noCase); } break; default: - Tcl_Panic("unknown switch mode: %d", mode); + TCL_UNREACHABLE(); } /* * In a fall-through case, we will jump on _true_ to the place * where the body starts (generated later, with guarantee of this @@ -2361,11 +2361,11 @@ CompileEnv *envPtr, /* Holds resulting instructions. */ int numBodyTokens, /* Number of tokens describing things the * switch can match against and bodies to * execute when the match succeeds. */ Tcl_Token **bodyToken, /* Array of pointers to pattern list items. */ - Tcl_Size *bodyLines, /* Array of line numbers for body list + Tcl_Size *bodyLines, /* Array of line numbers for body list * items. */ Tcl_Size **bodyContLines) /* Array of continuation line info. */ { JumptableInfo *jtPtr; int infoIndex, isNew, *finalFixups, numRealBodies = 0, jumpLocation; Index: generic/tclCompExpr.c ================================================================== --- generic/tclCompExpr.c +++ generic/tclCompExpr.c @@ -160,11 +160,11 @@ * BINARY_MINUS according to context. */ BAREWORD = 3, /* Ambiguous. Resolves to BOOL_LIT or to * 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 * expression, whichever comes first. */ @@ -221,11 +221,11 @@ * operator that separates the arguments in a * function call. The additional constraint * 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, LESS = BINARY | 7, GREATER = BINARY | 8, Index: generic/tclCompile.c ================================================================== --- generic/tclCompile.c +++ generic/tclCompile.c @@ -777,11 +777,11 @@ TclSetByteCodeFromAny( Tcl_Interp *interp, /* The interpreter for which the code is being * 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 * in frame. */ Tcl_Size length; @@ -1206,16 +1206,22 @@ return 0; /* Runtime evals */ 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); break; } @@ -2821,11 +2827,11 @@ } } 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; size_t codeBytes, objArrayBytes, exceptArrayBytes, cmdLocBytes; size_t auxDataArrayBytes, structureSize; @@ -2966,11 +2972,11 @@ TclInitByteCodeObj( Tcl_Obj *objPtr, /* Points object that should be initialized, * 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; PreventCycle(objPtr, envPtr); @@ -3011,11 +3017,11 @@ *---------------------------------------------------------------------- */ 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. */ int create, /* If 1, allocate a local frame entry for the * variable if it is new. */ @@ -3190,11 +3196,11 @@ * structure in which to enter command * location information. */ Tcl_Size cmdIndex, /* Index of the command whose start data is * being set. */ Tcl_Size srcOffset, /* Offset of first char of the command. */ - Tcl_Size codeOffset) /* Offset of first byte of command code. */ + Tcl_Size codeOffset) /* Offset of first byte of command code. */ { CmdLocation *cmdLocPtr; if (cmdIndex < 0 || cmdIndex >= envPtr->numCommands) { Tcl_Panic("EnterCmdStartData: bad command index %" TCL_Z_MODIFIER "u", cmdIndex); @@ -3268,12 +3274,12 @@ CompileEnv *envPtr, /* Points to the compilation environment * structure in which to enter command * location information. */ Tcl_Size cmdIndex, /* Index of the command whose source and code * length data is being set. */ - Tcl_Size numSrcBytes, /* Number of command source chars. */ - Tcl_Size numCodeBytes) /* Offset of last byte of command code. */ + Tcl_Size numSrcBytes, /* Number of command source chars. */ + Tcl_Size numCodeBytes) /* Offset of last byte of command code. */ { CmdLocation *cmdLocPtr; if (cmdIndex < 0 || cmdIndex >= envPtr->numCommands) { Tcl_Panic("EnterCmdExtentData: bad command index %" TCL_Z_MODIFIER "u", cmdIndex); @@ -3483,11 +3489,12 @@ { size_t i = envPtr->exceptArrayNext; 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) < (int)rangePtr->codeOffset+(int)rangePtr->numCodeBytes) && (returnCode != TCL_CONTINUE || @@ -3752,15 +3759,15 @@ *---------------------------------------------------------------------- */ 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. */ AuxData *auxDataPtr; /* Points to the new AuxData structure */ Index: generic/tclCompile.h ================================================================== --- generic/tclCompile.h +++ generic/tclCompile.h @@ -133,21 +133,21 @@ * looping level and the point of jump * issue. */ 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 + TCL_HASH_TYPE *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 * of this array to be updated. When * numBreakTargets==0, this is NULL. */ Tcl_Size allocBreakTargets; /* The size of the breakTargets array. */ 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; + TCL_HASH_TYPE *continueTargets; /* The offsets of the INST_JUMP4 instructions * issued by the [continue]s that we must * update. Note that resizing a jump (via * TclFixupForwardJump) can cause the contents * of this array to be updated. When @@ -221,11 +221,11 @@ typedef void * (AuxDataDupProc) (void *clientData); typedef void (AuxDataFreeProc) (void *clientData); typedef void (AuxDataPrintProc) (void *clientData, Tcl_Obj *appendObj, struct ByteCode *codePtr, - size_t pcOffset); + TCL_HASH_TYPE pcOffset); /* * We define a separate AuxDataType struct to hold type-related information * for the AuxData structure. This separation makes it possible for clients * outside of the TCL core to manipulate (in a limited fashion!) AuxData; for @@ -318,12 +318,14 @@ unsigned char *codeNext; /* Points to next code array byte to use. */ unsigned char *codeEnd; /* Points just after the last allocated code * 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. */ Tcl_Size literalArrayEnd; /* Index just after last obj array entry. */ int mallocedLiteralArray; /* 1 if object array was expanded and objArray @@ -335,10 +337,13 @@ * exceptArrayNext is the number of ranges and * (exceptArrayNext-1) is the index of the * 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 * exceptions. Must be the same size as the * exceptArrayPtr. */ @@ -347,18 +352,23 @@ * to use; (numCommands-1) is the entry index * for the last command. */ 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]; /* Initial storage of LiteralEntry array. */ ExceptionRange staticExceptArraySpace[COMPILEENV_INIT_EXCEPT_RANGES]; @@ -1060,10 +1070,11 @@ *---------------------------------------------------------------- * Procedures exported by tclBasic.c to be used within the engine. *---------------------------------------------------------------- */ +#if TCL_MAJOR_VERSION > 8 MODULE_SCOPE Tcl_ObjCmdProc TclNRInterpCoroutine; /* *---------------------------------------------------------------- * Procedures exported by the engine to be used by tclBasic.c @@ -1199,10 +1210,11 @@ const unsigned char *pc, Tcl_Obj **tosPtr); 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 */ /* *---------------------------------------------------------------- * Macros and flag values used by Tcl bytecode compilation and execution * modules inside the Tcl core but not used outside. @@ -1308,11 +1320,11 @@ if ((envPtr)->codeNext == (envPtr)->codeEnd) { \ TclExpandCodeArray(envPtr); \ } \ *(envPtr)->codeNext++ = (unsigned char) (op); \ TclUpdateAtCmdStart(op, envPtr); \ - TclUpdateStackReqs((unsigned char)op, 0, envPtr); \ + TclUpdateStackReqs(op, 0, envPtr); \ } while (0) /* * Macros to emit an integer operand. The ANSI C "prototype" for these macros * are: Index: generic/tclConfig.c ================================================================== --- generic/tclConfig.c +++ generic/tclConfig.c @@ -297,12 +297,11 @@ Tcl_SetObjResult(interp, listPtr); return TCL_OK; default: - Tcl_Panic("QueryConfigObjCmd: Unknown subcommand to 'pkgconfig'. This can't happen"); - break; + TCL_UNREACHABLE(); } return TCL_ERROR; } /* @@ -389,11 +388,11 @@ *---------------------------------------------------------------------- */ static void ConfigDictDeleteProc( - void *clientData, /* Pointer to Tcl_Obj. */ + void *clientData, /* Pointer to Tcl_Obj. */ TCL_UNUSED(Tcl_Interp *)) { Tcl_DecrRefCount((Tcl_Obj *)clientData); } Index: generic/tclDate.h ================================================================== --- generic/tclDate.h +++ generic/tclDate.h @@ -391,11 +391,11 @@ 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, CFMTT_PROC } CLCKTOK_TYPE; Index: generic/tclDecls.h ================================================================== --- generic/tclDecls.h +++ generic/tclDecls.h @@ -59,22 +59,22 @@ const char *name, const char *version, int exact, void *clientDataPtr); /* 2 */ EXTERN TCL_NORETURN void Tcl_Panic(const char *format, ...) TCL_FORMAT_PRINTF(1, 2); /* 3 */ -EXTERN void * Tcl_Alloc(size_t size); +EXTERN void * Tcl_Alloc(TCL_HASH_TYPE size); /* 4 */ EXTERN void Tcl_Free(void *ptr); /* 5 */ -EXTERN void * Tcl_Realloc(void *ptr, size_t size); +EXTERN void * Tcl_Realloc(void *ptr, TCL_HASH_TYPE size); /* 6 */ -EXTERN void * Tcl_DbCkalloc(size_t size, const char *file, +EXTERN void * Tcl_DbCkalloc(TCL_HASH_TYPE 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, size_t size, +EXTERN void * Tcl_DbCkrealloc(void *ptr, TCL_HASH_TYPE size, const char *file, int line); /* 9 */ EXTERN void Tcl_CreateFileHandler(int fd, int mask, Tcl_FileProc *proc, void *clientData); /* 10 */ @@ -126,13 +126,19 @@ Tcl_Size length, const char *file, int line); /* 29 */ EXTERN Tcl_Obj * Tcl_DuplicateObj(Tcl_Obj *objPtr); /* 30 */ EXTERN void TclFreeObj(Tcl_Obj *objPtr); -/* Slot 31 is reserved */ -/* Slot 32 is reserved */ -/* Slot 33 is reserved */ +/* 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); /* 34 */ EXTERN int Tcl_GetDouble(Tcl_Interp *interp, const char *src, double *doublePtr); /* 35 */ EXTERN int Tcl_GetDoubleFromObj(Tcl_Interp *interp, @@ -239,11 +245,12 @@ EXTERN void Tcl_CallWhenDeleted(Tcl_Interp *interp, Tcl_InterpDeleteProc *proc, void *clientData); /* 80 */ EXTERN void Tcl_CancelIdleCall(Tcl_IdleProc *idleProc, void *clientData); -/* Slot 81 is reserved */ +/* 81 */ +EXTERN int Tcl_Close(Tcl_Interp *interp, Tcl_Channel chan); /* 82 */ EXTERN int Tcl_CommandComplete(const char *cmd); /* 83 */ EXTERN char * Tcl_Concat(Tcl_Size argc, const char *const *argv); /* 84 */ @@ -1027,11 +1034,11 @@ /* 392 */ EXTERN void Tcl_MutexFinalize(Tcl_Mutex *mutex); /* 393 */ EXTERN int Tcl_CreateThread(Tcl_ThreadId *idPtr, Tcl_ThreadCreateProc *proc, void *clientData, - size_t stackSize, int flags); + TCL_HASH_TYPE stackSize, int flags); /* 394 */ EXTERN Tcl_Size Tcl_ReadRaw(Tcl_Channel chan, char *dst, Tcl_Size bytesToRead); /* 395 */ EXTERN Tcl_Size Tcl_WriteRaw(Tcl_Channel chan, const char *src, @@ -1093,11 +1100,13 @@ /* 418 */ 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); /* 424 */ EXTERN void Tcl_InitObjHashTable(Tcl_HashTable *tablePtr); @@ -1113,18 +1122,18 @@ /* 427 */ EXTERN void Tcl_UntraceCommand(Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *proc, void *clientData); /* 428 */ -EXTERN void * Tcl_AttemptAlloc(size_t size); +EXTERN void * Tcl_AttemptAlloc(TCL_HASH_TYPE size); /* 429 */ -EXTERN void * Tcl_AttemptDbCkalloc(size_t size, const char *file, - int line); +EXTERN void * Tcl_AttemptDbCkalloc(TCL_HASH_TYPE size, + const char *file, int line); /* 430 */ -EXTERN void * Tcl_AttemptRealloc(void *ptr, size_t size); +EXTERN void * Tcl_AttemptRealloc(void *ptr, TCL_HASH_TYPE size); /* 431 */ -EXTERN void * Tcl_AttemptDbCkrealloc(void *ptr, size_t size, +EXTERN void * Tcl_AttemptDbCkrealloc(void *ptr, TCL_HASH_TYPE size, const char *file, int line); /* 432 */ EXTERN int Tcl_AttemptSetObjLength(Tcl_Obj *objPtr, Tcl_Size length); /* 433 */ @@ -1399,11 +1408,11 @@ /* 530 */ EXTERN void Tcl_LimitTypeSet(Tcl_Interp *interp, int type); /* 531 */ EXTERN void Tcl_LimitTypeReset(Tcl_Interp *interp, int type); /* 532 */ -EXTERN Tcl_Size Tcl_LimitGetCommands(Tcl_Interp *interp); +EXTERN int Tcl_LimitGetCommands(Tcl_Interp *interp); /* 533 */ EXTERN void Tcl_LimitGetTime(Tcl_Interp *interp, Tcl_Time *timeLimitPtr); /* 534 */ EXTERN int Tcl_LimitGetGranularity(Tcl_Interp *interp, int type); @@ -1702,11 +1711,11 @@ const char *mountPoint, int copy); /* 636 */ EXTERN void Tcl_FreeInternalRep(Tcl_Obj *objPtr); /* 637 */ EXTERN char * Tcl_InitStringRep(Tcl_Obj *objPtr, const char *bytes, - size_t numBytes); + TCL_HASH_TYPE numBytes); /* 638 */ EXTERN Tcl_ObjInternalRep * Tcl_FetchInternalRep(Tcl_Obj *objPtr, const Tcl_ObjType *typePtr); /* 639 */ EXTERN void Tcl_StoreInternalRep(Tcl_Obj *objPtr, @@ -1865,12 +1874,10 @@ EXTERN Tcl_Obj * Tcl_NewWideUIntObj(Tcl_WideUInt wideValue); /* 689 */ 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 { const struct TclPlatStubs *tclPlatStubs; const struct TclIntStubs *tclIntStubs; @@ -1882,16 +1889,16 @@ const TclStubHooks *hooks; 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) (size_t size); /* 3 */ + void * (*tcl_Alloc) (TCL_HASH_TYPE size); /* 3 */ void (*tcl_Free) (void *ptr); /* 4 */ - void * (*tcl_Realloc) (void *ptr, size_t size); /* 5 */ - void * (*tcl_DbCkalloc) (size_t size, const char *file, int line); /* 6 */ + 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_DbCkfree) (void *ptr, const char *file, int line); /* 7 */ - void * (*tcl_DbCkrealloc) (void *ptr, size_t size, const char *file, int line); /* 8 */ + void * (*tcl_DbCkrealloc) (void *ptr, TCL_HASH_TYPE 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 */ void (*tcl_Sleep) (int ms); /* 12 */ int (*tcl_WaitForEvent) (const Tcl_Time *timePtr); /* 13 */ @@ -1910,13 +1917,13 @@ void (*reserved26)(void); Tcl_Obj * (*tcl_DbNewObj) (const char *file, int line); /* 27 */ 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 */ - void (*reserved31)(void); - void (*reserved32)(void); - void (*reserved33)(void); + 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 */ 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); int (*tcl_GetInt) (Tcl_Interp *interp, const char *src, int *intPtr); /* 37 */ int (*tcl_GetIntFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *intPtr); /* 38 */ @@ -1960,11 +1967,11 @@ void (*reserved76)(void); void (*reserved77)(void); 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 */ - void (*reserved81)(void); + int (*tcl_Close) (Tcl_Interp *interp, Tcl_Channel chan); /* 81 */ 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 */ Tcl_Size (*tcl_ConvertCountedElement) (const char *src, Tcl_Size length, char *dst, int flags); /* 85 */ int (*tcl_CreateAlias) (Tcl_Interp *childInterp, const char *childCmd, Tcl_Interp *target, const char *targetCmd, Tcl_Size argc, const char *const *argv); /* 86 */ @@ -2272,11 +2279,11 @@ int (*tcl_GetChannelNames) (Tcl_Interp *interp); /* 388 */ int (*tcl_GetChannelNamesEx) (Tcl_Interp *interp, const char *pattern); /* 389 */ 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, size_t stackSize, int flags); /* 393 */ + int (*tcl_CreateThread) (Tcl_ThreadId *idPtr, Tcl_ThreadCreateProc *proc, void *clientData, TCL_HASH_TYPE 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 */ int (*tcl_ChannelBuffered) (Tcl_Channel chan); /* 397 */ const char * (*tcl_ChannelName) (const Tcl_ChannelType *chanTypePtr); /* 398 */ @@ -2301,20 +2308,20 @@ void (*tcl_ClearChannelHandlers) (Tcl_Channel channel); /* 417 */ int (*tcl_IsChannelExisting) (const char *channelName); /* 418 */ 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 */ 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) (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 */ + 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 */ 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 */ void (*reserved435)(void); void (*reserved436)(void); @@ -2411,11 +2418,11 @@ void (*tcl_LimitSetGranularity) (Tcl_Interp *interp, int type, int granularity); /* 527 */ int (*tcl_LimitTypeEnabled) (Tcl_Interp *interp, int type); /* 528 */ 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 */ - Tcl_Size (*tcl_LimitGetCommands) (Tcl_Interp *interp); /* 532 */ + int (*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 */ int (*tcl_RestoreInterpState) (Tcl_Interp *interp, Tcl_InterpState state); /* 536 */ void (*tcl_DiscardInterpState) (Tcl_InterpState state); /* 537 */ @@ -2516,11 +2523,11 @@ int (*tclZipfs_Mount) (Tcl_Interp *interp, const char *zipname, const char *mountPoint, const char *passwd); /* 632 */ int (*tclZipfs_Unmount) (Tcl_Interp *interp, const char *mountPoint); /* 633 */ 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, size_t numBytes); /* 637 */ + char * (*tcl_InitStringRep) (Tcl_Obj *objPtr, const char *bytes, TCL_HASH_TYPE 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 */ void (*tcl_IncrRefCount) (Tcl_Obj *objPtr); /* 641 */ void (*tcl_DecrRefCount) (Tcl_Obj *objPtr); /* 642 */ @@ -2569,12 +2576,11 @@ Tcl_Obj * (*tcl_DStringToObj) (Tcl_DString *dsPtr); /* 685 */ int (*tcl_UtfNcmp) (const char *s1, const char *s2, size_t n); /* 686 */ 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 */ - int (*tcl_IsEmpty) (Tcl_Obj *obj); /* 690 */ - void (*tclUnusedStubEntry) (void); /* 691 */ + void (*tclUnusedStubEntry) (void); /* 690 */ } TclStubs; extern const TclStubs *tclStubsPtr; #ifdef __cplusplus @@ -2645,13 +2651,16 @@ (tclStubsPtr->tcl_DbNewStringObj) /* 28 */ #define Tcl_DuplicateObj \ (tclStubsPtr->tcl_DuplicateObj) /* 29 */ #define TclFreeObj \ (tclStubsPtr->tclFreeObj) /* 30 */ -/* Slot 31 is reserved */ -/* Slot 32 is reserved */ -/* Slot 33 is reserved */ +#define Tcl_GetBoolean \ + (tclStubsPtr->tcl_GetBoolean) /* 31 */ +#define Tcl_GetBooleanFromObj \ + (tclStubsPtr->tcl_GetBooleanFromObj) /* 32 */ +#define Tcl_GetByteArrayFromObj \ + (tclStubsPtr->tcl_GetByteArrayFromObj) /* 33 */ #define Tcl_GetDouble \ (tclStubsPtr->tcl_GetDouble) /* 34 */ #define Tcl_GetDoubleFromObj \ (tclStubsPtr->tcl_GetDoubleFromObj) /* 35 */ /* Slot 36 is reserved */ @@ -2731,11 +2740,12 @@ (tclStubsPtr->tcl_BadChannelOption) /* 78 */ #define Tcl_CallWhenDeleted \ (tclStubsPtr->tcl_CallWhenDeleted) /* 79 */ #define Tcl_CancelIdleCall \ (tclStubsPtr->tcl_CancelIdleCall) /* 80 */ -/* Slot 81 is reserved */ +#define Tcl_Close \ + (tclStubsPtr->tcl_Close) /* 81 */ #define Tcl_CommandComplete \ (tclStubsPtr->tcl_CommandComplete) /* 82 */ #define Tcl_Concat \ (tclStubsPtr->tcl_Concat) /* 83 */ #define Tcl_ConvertElement \ @@ -3367,11 +3377,12 @@ #define Tcl_IsChannelExisting \ (tclStubsPtr->tcl_IsChannelExisting) /* 418 */ /* 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 \ (tclStubsPtr->tcl_InitObjHashTable) /* 424 */ #define Tcl_CommandTraceInfo \ @@ -3899,14 +3910,12 @@ (tclStubsPtr->tcl_UtfNcasecmp) /* 687 */ #define Tcl_NewWideUIntObj \ (tclStubsPtr->tcl_NewWideUIntObj) /* 688 */ #define Tcl_SetWideUIntObj \ (tclStubsPtr->tcl_SetWideUIntObj) /* 689 */ -#define Tcl_IsEmpty \ - (tclStubsPtr->tcl_IsEmpty) /* 690 */ #define TclUnusedStubEntry \ - (tclStubsPtr->tclUnusedStubEntry) /* 691 */ + (tclStubsPtr->tclUnusedStubEntry) /* 690 */ #endif /* defined(USE_TCL_STUBS) */ /* !END!: Do not edit above this line. */ @@ -3972,10 +3981,27 @@ } \ } \ } 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 * Win64 signature. Cygwin64 stubbed extensions cannot use those stub * entries any more, they should use the 64-bit alternatives where @@ -4003,10 +4029,11 @@ # endif #endif #undef Tcl_GetString #undef Tcl_GetUnicode +#undef Tcl_CreateHashEntry #define Tcl_GetString(objPtr) \ Tcl_GetStringFromObj(objPtr, (Tcl_Size *)NULL) #define Tcl_GetUnicode(objPtr) \ Tcl_GetUnicodeFromObj(objPtr, (Tcl_Size *)NULL) #undef Tcl_GetIndexFromObjStruct @@ -4024,26 +4051,30 @@ #endif /* !TCLBOOLWARNING */ #if defined(USE_TCL_STUBS) #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_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)) +#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))) #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_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)) +#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))) #endif #ifdef TCL_MEM_DEBUG # undef Tcl_Alloc # define Tcl_Alloc(x) \ @@ -4136,11 +4167,15 @@ #define Tcl_EvalObj(interp, objPtr) \ Tcl_EvalObjEx(interp, objPtr, 0) #define Tcl_GlobalEvalObj(interp, objPtr) \ Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL) -#define Tcl_Close(interp, chan) Tcl_CloseEx(interp, chan, 0) + +#if TCL_MAJOR_VERSION > 8 +# undef Tcl_Close +# define Tcl_Close(interp, chan) Tcl_CloseEx(interp, chan, 0) +#endif #undef TclUtfCharComplete #undef TclUtfNext #undef TclUtfPrev #ifndef TCL_NO_DEPRECATED @@ -4160,11 +4195,59 @@ #undef TclSplitPath #undef TclFSSplitPath #undef TclParseArgsObjv #undef TclGetAliasObj -#if defined(TCL_8_API) +#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 # undef Tcl_GetBytesFromObj # undef Tcl_GetStringFromObj # undef Tcl_GetUnicodeFromObj # undef Tcl_ListObjGetElements # undef Tcl_ListObjLength @@ -4173,10 +4256,13 @@ # undef Tcl_SplitPath # undef Tcl_FSSplitPath # 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))) # define Tcl_GetStringFromObj(objPtr, sizePtr) (sizeof(*(sizePtr)) <= sizeof(int) ? \ (TclGetStringFromObj)((objPtr), (sizePtr)) : \ @@ -4207,10 +4293,13 @@ (Tcl_ParseArgsObjv)((interp), (argTable), (Tcl_Size *)(void *)(objcPtr), (objv), (remObjv))) # define Tcl_GetAliasObj(interp, childCmd, targetInterpPtr, targetCmdPtr, objcPtr, objv) (sizeof(*(objcPtr)) <= sizeof(int) ? \ 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))) # define Tcl_GetStringFromObj(objPtr, sizePtr) (sizeof(*(sizePtr)) <= sizeof(int) ? \ tclStubsPtr->tclGetStringFromObj((objPtr), (sizePtr)) : \ @@ -4241,14 +4330,12 @@ tclStubsPtr->tcl_ParseArgsObjv((interp), (argTable), (Tcl_Size *)(void *)(objcPtr), (objv), (remObjv))) # define Tcl_GetAliasObj(interp, childCmd, targetInterpPtr, targetCmdPtr, objcPtr, objv) (sizeof(*(objcPtr)) <= sizeof(int) ? \ tclStubsPtr->tclGetAliasObj((interp), (childCmd), (targetInterpPtr), (targetCmdPtr), (objcPtr), (objv)) : \ tclStubsPtr->tcl_GetAliasObj((interp), (childCmd), (targetInterpPtr), (targetCmdPtr), (Tcl_Size *)(void *)(objcPtr), (objv))) # endif /* defined(USE_TCL_STUBS) */ +#else /* !defined(TCL_8_API) */ +# undef Tcl_GetByteArrayFromObj +# define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \ + Tcl_GetBytesFromObj(NULL, (objPtr), (sizePtr)) #endif /* defined(TCL_8_API) */ -#define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \ - Tcl_GetBytesFromObj(NULL, (objPtr), (sizePtr)) - -#if TCL_MINOR_VERSION < 1 -# undef Tcl_IsEmpty -#endif #endif /* _TCLDECLS */ Index: generic/tclDictObj.c ================================================================== --- generic/tclDictObj.c +++ generic/tclDictObj.c @@ -175,11 +175,11 @@ * *this* file. Everything else should use the dict iterator API. */ 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, TclFreeObjEntry }; @@ -1263,11 +1263,11 @@ *---------------------------------------------------------------------- */ void Tcl_DictObjDone( - Tcl_DictSearch *searchPtr) /* Pointer to a hash search context. */ + Tcl_DictSearch *searchPtr) /* Pointer to a hash search context. */ { Dict *dict; if (searchPtr->epoch) { searchPtr->epoch = 0; @@ -3419,18 +3419,19 @@ * do. */ Tcl_ResetResult(interp); Tcl_DictObjDone(&search); - /* FALLTHRU */ + TCL_FALLTHROUGH(); case TCL_CONTINUE: result = TCL_OK; break; case TCL_ERROR: Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (\"dict filter\" script line %d)", Tcl_GetErrorLine(interp))); + TCL_FALLTHROUGH(); default: goto abnormalResult; } TclDecrRefCount(keyObj); @@ -3452,24 +3453,22 @@ Tcl_SetObjResult(interp, resultObj); } else { 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; } /* *---------------------------------------------------------------------- * Index: generic/tclEncoding.c ================================================================== --- generic/tclEncoding.c +++ generic/tclEncoding.c @@ -1226,11 +1226,11 @@ * of a multibyte character * In both cases we have to grow buffer, move the input source pointer * 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); if (errorLocPtr) { /* @@ -1542,11 +1542,11 @@ * of a multibyte character * In both cases we have to grow buffer, move the input source pointer * 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 */ while (i >= soFar) { Tcl_DStringSetLength(dstPtr, i--); @@ -2582,11 +2582,12 @@ ch = UNICODE_REPLACE_CHAR; ++src; } 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); } else { /* Have a complete character */ @@ -3055,11 +3056,11 @@ } else { /* High surrogate was not followed by a low surrogate */ 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)) { /* * Previous loop wrote a single byte to mark the high surrogate. @@ -3508,11 +3509,12 @@ } if (PROFILE_REPLACE(flags)) { ch = UNICODE_REPLACE_CHAR; } else { char chbuf[2]; - chbuf[0] = byte; chbuf[1] = 0; + chbuf[0] = byte; + chbuf[1] = 0; TclUtfToUniChar(chbuf, &ch); } } /* @@ -4064,10 +4066,34 @@ ch = tableToUnicode[hi][lo]; dst += Tcl_UniCharToUtf(ch, dst); src++; 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; *dstCharsPtr = numChars; Index: generic/tclEnsemble.c ================================================================== --- generic/tclEnsemble.c +++ generic/tclEnsemble.c @@ -22,11 +22,11 @@ static int ReadOneEnsembleOption(Tcl_Interp *interp, Tcl_Command token, Tcl_Obj *optionObj); static int ReadAllEnsembleOptions(Tcl_Interp *interp, Tcl_Command token); static int SetEnsembleConfigOptions(Tcl_Interp *interp, - Tcl_Command token, Tcl_Size objc, + Tcl_Command token, int objc, Tcl_Obj *const objv[]); static inline int EnsembleUnknownCallback(Tcl_Interp *interp, EnsembleConfig *ensemblePtr, int objc, Tcl_Obj *const objv[], Tcl_Obj **prefixObjPtr); static int NsEnsembleImplementationCmdNR(void *clientData, @@ -228,13 +228,12 @@ } else { return SetEnsembleConfigOptions(interp, token, objc - 3, objv + 3); } default: - Tcl_Panic("unexpected ensemble command"); + TCL_UNREACHABLE(); } - return TCL_OK; } /* *---------------------------------------------------------------------- * @@ -385,10 +384,12 @@ if (TclListObjLength(interp, objv[1], &len) != TCL_OK) { goto error; } unknownObj = (len > 0 ? objv[1] : NULL); continue; + default: + TCL_UNREACHABLE(); } } TclGetNamespaceForQualName(interp, name, cxtPtr, TCL_CREATE_NS_IF_UNKNOWN, &foundNsPtr, &altFoundNsPtr, @@ -483,10 +484,12 @@ Tcl_GetEnsembleUnknownHandler(NULL, token, &resultObj); if (resultObj != NULL) { Tcl_SetObjResult(interp, resultObj); } break; + default: + TCL_UNREACHABLE(); } return TCL_OK; } /* *---------------------------------------------------------------------- @@ -583,11 +586,11 @@ */ static int SetEnsembleConfigOptions( Tcl_Interp *interp, Tcl_Command token, /* The ensemble to configure. */ - Tcl_Size objc, /* The count of option-related arguments. */ + int objc, /* The count of option-related arguments. */ Tcl_Obj *const objv[]) /* Option-related arguments. */ { Tcl_Size len; int allocatedMapFlag = 0; Tcl_Obj *subcmdObj = NULL, *mapObj = NULL, *paramObj = NULL, @@ -713,10 +716,12 @@ if (TclListObjLength(interp, objv[1], &len) != TCL_OK) { goto freeMapAndError; } unknownObj = (len > 0 ? objv[1] : NULL); continue; + default: + TCL_UNREACHABLE(); } } /* * Update the namespace now that we've finished the parsing stage. @@ -1576,12 +1581,11 @@ Tcl_Namespace *ns; Tcl_DString buf, hiddenBuf; const char **nameParts = NULL; const char *cmdName = NULL; Tcl_Size i, nameCount = 0; - int ensembleFlags = 0; - Tcl_Size hiddenLen; + int ensembleFlags = 0, hiddenLen; /* * Construct the path for the ensemble namespace and create it. */ Index: generic/tclEnv.c ================================================================== --- generic/tclEnv.c +++ generic/tclEnv.c @@ -43,11 +43,11 @@ static struct { Tcl_Size cacheSize; /* Number of env strings in cache. */ 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. */ Tcl_Size ourEnvironSize; /* Non-zero means that the environ array was * malloced and has this many total entries Index: generic/tclEvent.c ================================================================== --- generic/tclEvent.c +++ generic/tclEvent.c @@ -70,11 +70,11 @@ * there is a structure of the following type: */ 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; /* @@ -120,11 +120,11 @@ 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 */ /* @@ -210,11 +210,11 @@ *---------------------------------------------------------------------- */ static void HandleBgErrors( - void *clientData) /* Pointer to ErrAssocData structure. */ + void *clientData) /* Pointer to ErrAssocData structure. */ { ErrAssocData *assocPtr = (ErrAssocData *)clientData; Tcl_Interp *interp = assocPtr->interp; BgError *errPtr; @@ -598,11 +598,11 @@ *---------------------------------------------------------------------- */ static void BgErrorDeleteProc( - void *clientData, /* Pointer to ErrAssocData structure. */ + void *clientData, /* Pointer to ErrAssocData structure. */ TCL_UNUSED(Tcl_Interp *)) { ErrAssocData *assocPtr = (ErrAssocData *)clientData; BgError *errPtr; @@ -637,11 +637,11 @@ */ 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)); exitPtr->proc = proc; exitPtr->clientData = clientData; @@ -670,11 +670,11 @@ */ 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)); exitPtr->proc = proc; exitPtr->clientData = clientData; @@ -703,11 +703,11 @@ */ 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; Tcl_MutexLock(&exitMutex); for (prevPtr = NULL, exitPtr = firstExitPtr; exitPtr != NULL; @@ -746,11 +746,11 @@ */ 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; Tcl_MutexLock(&exitMutex); for (prevPtr = NULL, exitPtr = firstLateExitPtr; exitPtr != NULL; @@ -789,11 +789,11 @@ */ 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); exitPtr = (ExitHandler*)Tcl_Alloc(sizeof(ExitHandler)); @@ -822,11 +822,11 @@ */ 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); for (prevPtr = NULL, exitPtr = tsdPtr->firstExitPtr; exitPtr != NULL; @@ -1648,10 +1648,12 @@ vwaitItems[numItems].sequence = -1; vwaitItems[numItems].mask = TCL_WRITABLE; vwaitItems[numItems].sourceObj = objv[i]; numItems++; break; + default: + TCL_UNREACHABLE(); } } endOfOptionLoop: if ((mask & (TCL_FILE_EVENTS | TCL_IDLE_EVENTS | @@ -1965,11 +1967,11 @@ switch (optionIndex) { case OPT_IDLETASKS: 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?"); return TCL_ERROR; } Index: generic/tclExecute.c ================================================================== --- generic/tclExecute.c +++ generic/tclExecute.c @@ -153,26 +153,21 @@ #define VarHashGetValue(hPtr) \ ((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 * will resolve all branches at compile time. (result) is always a constant; * the macro NEXT_INST_F handles constant (nCleanup), NEXT_INST_V is resolved @@ -940,13 +935,13 @@ static inline int wordSkip( void *ptr) { - int mask = TCL_ALLOCALIGN-1; - int base = (int)PTR2INT(ptr) & mask; - return (TCL_ALLOCALIGN - base)/(int)sizeof(Tcl_Obj *); + size_t mask = TCL_ALLOCALIGN-1; + size_t base = PTR2UINT(ptr) & mask; + return (TCL_ALLOCALIGN - base)/sizeof(Tcl_Obj *); } /* * Given a marker, compute where the following aligned memory starts. */ @@ -4718,34 +4713,30 @@ /* special case for AbstractList */ if (TclObjTypeHasProc(valuePtr, indexProc)) { DECACHE_STACK_INFO(); 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) { - CACHE_STACK_INFO(); - TRACE_ERROR(interp); - goto gotError; - } - CACHE_STACK_INFO(); - if (objResultPtr == NULL) { - /* Index is out of range, return empty result. */ - TclNewObj(objResultPtr); - } - Tcl_IncrRefCount(objResultPtr); // reference held here - goto lindexDone; - } - - /* - * Extract the desired list element. - */ - - { + if (TclGetIntForIndexM(NULL, value2Ptr, length-1, &index)!=TCL_OK) { + CACHE_STACK_INFO(); + /* 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(); + if (objResultPtr == NULL) { + /* Index is out of range, return empty result. */ + TclNewObj(objResultPtr); + } + Tcl_IncrRefCount(objResultPtr); // reference held here + goto lindexDone; + } + } else { + /* Non-abstract list */ Tcl_Size value2Length; Tcl_Obj *indexListPtr = value2Ptr; if ((TclListObjGetElements(interp, valuePtr, &objc, &objv) == TCL_OK) && (!TclHasInternalRep(value2Ptr, &tclListType) @@ -9561,36 +9552,14 @@ int 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; } /* *---------------------------------------------------------------------- * @@ -9936,11 +9905,11 @@ * below... */ } } 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", decadeHigh, Percent(sum, statsPtr->numCompilations)); } Index: generic/tclFileName.c ================================================================== --- generic/tclFileName.c +++ generic/tclFileName.c @@ -1231,10 +1231,12 @@ i++; break; case GLOB_LAST: /* -- */ i++; goto endOfForLoop; + default: + TCL_UNREACHABLE(); } } endOfForLoop: if ((globFlags & TCL_GLOBMODE_TAILS) && (pathOrDir == NULL)) { Index: generic/tclHash.c ================================================================== --- generic/tclHash.c +++ generic/tclHash.c @@ -11,10 +11,16 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #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. */ @@ -280,11 +286,11 @@ continue; } /* 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; } } @@ -295,11 +301,11 @@ continue; } /* 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; } } @@ -309,19 +315,20 @@ hPtr = hPtr->nextPtr) { if (hash != hPtr->hash) { continue; } if (key == hPtr->key.oneWordValue) { - if (newPtr) { + if (newPtr && (newPtr != TCL_HASH_FIND)) { *newPtr = 0; } return hPtr; } } } - if (!newPtr) { + if (!newPtr || (newPtr == TCL_HASH_FIND)) { + /* This is the findProc functionality, so we are done. */ return NULL; } /* * Entry not found. Add a new one to the bucket. Index: generic/tclIO.c ================================================================== --- generic/tclIO.c +++ generic/tclIO.c @@ -6071,12 +6071,12 @@ * 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)) { + if (GotFlag(statePtr, CHANNEL_EOF) + || GotFlag(statePtr, CHANNEL_ENCODING_ERROR)) { break; } if ((GotFlag(statePtr, CHANNEL_NONBLOCKING) || allowShortReads) && GotFlag(statePtr, CHANNEL_BLOCKED)) { Index: generic/tclIO.h ================================================================== --- generic/tclIO.h +++ generic/tclIO.h @@ -93,11 +93,11 @@ * Tcl channel mechanism, and it points at an instance specific (and type * specific) instance data, and at a channel type structure. */ 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. */ struct Channel *downChanPtr;/* Refers to channel this one was stacked * upon. This reference is NULL for normal @@ -156,10 +156,15 @@ TclEolTranslation outputTranslation; /* What translation to use for generating end * 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. */ Tcl_Size refCount; /* How many interpreters hold references to * this IO channel? */ Index: generic/tclIOCmd.c ================================================================== --- generic/tclIOCmd.c +++ generic/tclIOCmd.c @@ -133,11 +133,11 @@ if (strcmp(TclGetString(objv[1]), "-nonewline") == 0) { chanObjPtr = objv[2]; 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"); return TCL_ERROR; } @@ -367,12 +367,12 @@ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { 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; if ((objc != 2) && (objc != 3)) { Interp *iPtr; @@ -908,15 +908,16 @@ const char *string; Tcl_Channel chan; 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. */ @@ -929,16 +930,28 @@ } if (Tcl_GetIndexFromObj(interp, objv[skip], options, "option", 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; } } if (objc <= skip) { Tcl_WrongNumArgs(interp, 1, objv, "?-option ...? arg ?arg ...?"); @@ -984,15 +997,10 @@ if (chan == NULL) { 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 * detach the PIDs (instead of waiting for them). */ @@ -1001,10 +1009,24 @@ if (Tcl_CloseEx(interp, chan, 0) != TCL_OK) { return TCL_ERROR; } 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) { /* @@ -1237,11 +1259,11 @@ *---------------------------------------------------------------------- */ 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 *)) { Tcl_HashTable *hTblPtr = (Tcl_HashTable *)clientData; Tcl_HashEntry *hPtr; @@ -1365,11 +1387,11 @@ *---------------------------------------------------------------------- */ 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 * connection. */ char *address, /* Address of client that was accepted. */ @@ -1456,11 +1478,11 @@ *---------------------------------------------------------------------- */ 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; /* The actual data. */ @@ -1603,11 +1625,11 @@ if (Tcl_GetIntFromObj(interp, objv[a], &backlog) != TCL_OK) { return TCL_ERROR; } break; default: - Tcl_Panic("Tcl_SocketObjCmd: bad option index to SocketOptions"); + TCL_UNREACHABLE(); } } if (server) { host = myaddr; /* NULL implies INADDR_ANY */ if (myport != 0) { @@ -1808,10 +1830,12 @@ } break; case FcopyCommand: cmdPtr = objv[i+1]; break; + default: + TCL_UNREACHABLE(); } } return TclCopyChannel(interp, inChan, outChan, toRead, cmdPtr); } @@ -1874,10 +1898,12 @@ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(-1)); } else { Tcl_SetObjResult(interp, Tcl_NewWideIntObj(Tcl_OutputBuffered(chan))); } break; + default: + TCL_UNREACHABLE(); } return TCL_OK; } /* Index: generic/tclIOGT.c ================================================================== --- generic/tclIOGT.c +++ generic/tclIOGT.c @@ -513,11 +513,11 @@ *---------------------------------------------------------------------- */ static int TransformBlockModeProc( - void *instanceData, /* State of transformation. */ + void *instanceData, /* State of transformation. */ int mode) /* New blocking mode. */ { TransformChannelData *dataPtr = (TransformChannelData *)instanceData; if (mode == TCL_MODE_NONBLOCKING) { @@ -1011,11 +1011,11 @@ *---------------------------------------------------------------------- */ static void TransformWatchProc( - void *instanceData, /* Channel to watch. */ + void *instanceData, /* Channel to watch. */ int mask) /* Events of interest. */ { TransformChannelData *dataPtr = (TransformChannelData *)instanceData; Tcl_Channel downChan; @@ -1089,13 +1089,13 @@ *---------------------------------------------------------------------- */ 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; /* * Return the handle belonging to parent channel. IOW, pass the request @@ -1123,11 +1123,11 @@ *---------------------------------------------------------------------- */ 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. */ { TransformChannelData *dataPtr = (TransformChannelData *)clientData; @@ -1168,11 +1168,11 @@ *---------------------------------------------------------------------- */ static void TransformChannelHandlerTimer( - void *clientData) /* Transformation to query. */ + void *clientData) /* Transformation to query. */ { TransformChannelData *dataPtr = (TransformChannelData *)clientData; dataPtr->timer = NULL; if (!(dataPtr->watchMask&TCL_READABLE) || ResultEmpty(&dataPtr->result)) { Index: generic/tclIORChan.c ================================================================== --- generic/tclIORChan.c +++ generic/tclIORChan.c @@ -160,11 +160,11 @@ */ 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", /* */ "read", /* OPT */ "seek", /* OPT */ @@ -1776,11 +1776,11 @@ *---------------------------------------------------------------------- */ 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 */ { ReflectedChannel *rcPtr = (ReflectedChannel *)clientData; @@ -1848,11 +1848,11 @@ *---------------------------------------------------------------------- */ 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 */ { /* @@ -2001,11 +2001,11 @@ *---------------------------------------------------------------------- */ static int ReflectTruncate( - void *clientData, /* Channel to query */ + void *clientData, /* Channel to query */ long long length) /* Length to truncate to. */ { ReflectedChannel *rcPtr = (ReflectedChannel *)clientData; Tcl_Obj *lenObj; int errorNum; /* EINVAL or EOK (success). */ @@ -2084,11 +2084,11 @@ const char *objName, Tcl_Obj *obj, 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. */ if (TclListObjGetElements(interp, obj, &listc, &listv) != TCL_OK) { @@ -2106,10 +2106,12 @@ events |= TCL_READABLE; break; case EVENT_WRITE: events |= TCL_WRITABLE; break; + default: + TCL_UNREACHABLE(); } listc --; } *mask = events; @@ -2561,17 +2563,17 @@ rcPtr->dead = 1; } 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 ForwardingResult *resultPtr; ForwardingEvent *evPtr; Index: generic/tclIORTrans.c ================================================================== --- generic/tclIORTrans.c +++ generic/tclIORTrans.c @@ -2104,12 +2104,12 @@ DeleteReflectedTransformMap( void *clientData, /* The per-interpreter data structure. */ 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; ForwardingEvent *evPtr; ForwardParam *paramPtr; @@ -2266,12 +2266,12 @@ 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; /* Index: generic/tclIOUtil.c ================================================================== --- generic/tclIOUtil.c +++ generic/tclIOUtil.c @@ -206,12 +206,12 @@ /* * A files-system indepent sense of the current directory. */ -static Tcl_Obj *cwdPathPtr = NULL; /* The pathname of the current directory */ -static size_t cwdPathEpoch = 0; +static Tcl_Obj *cwdPathPtr = NULL; +static size_t cwdPathEpoch = 0; /* The pathname of the current directory */ static void *cwdClientData = NULL; TCL_DECLARE_MUTEX(cwdMutex) static Tcl_ThreadDataKey fsDataKey; @@ -1321,12 +1321,12 @@ Tcl_Obj *pathPtr, /* An Pathname to normalize in-place. Must be * unshared. */ 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; Tcl_Size i; int isVfsPath = 0; @@ -2910,11 +2910,11 @@ } 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 * its internal handle may be different from what was found above. * This can easily be the case with scripted documents . Therefore get @@ -3375,11 +3375,11 @@ tvdlPtr->loadHandle = newLoadHandle; tvdlPtr->unloadProcPtr = newUnloadProcPtr; if (copyFsPtr != &tclNativeFilesystem) { - /* refCount of copyToPtr is already incremented. */ + /* refCount of copyToPtr is already incremented. */ tvdlPtr->divertedFile = copyToPtr; /* * This is the filesystem for the temporary file the object was loaded * from. A reference to copyToPtr is already stored in @@ -4339,11 +4339,11 @@ int 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 * the name of the file that produced an error. */ { @@ -4458,11 +4458,11 @@ if (fsRecPtr->fsPtr->pathInFilesystemProc(pathPtr, &clientData)!=-1) { /* 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(); return fsRecPtr->fsPtr; } Index: generic/tclIcu.c ================================================================== --- generic/tclIcu.c +++ generic/tclIcu.c @@ -796,11 +796,11 @@ dstLen = ucnv_fromUChars(ucnvPtr, Tcl_DStringValue(dsOutPtr), (int)dstLen, utf16, (int)utf16len, &status); if (U_SUCCESS(status)) { break; } - /* FALLTHRU */ + TCL_FALLTHROUGH(); default: Tcl_DStringFree(dsOutPtr); ucnv_close(ucnvPtr); return IcuError(interp, "ICU error while encoding", status); } @@ -876,11 +876,11 @@ dstLen = ucnv_toUChars(ucnvPtr, (UCharx *)Tcl_DStringValue(dsOutPtr), dstCapacity, (const char *)bytes, (int)nbytes, &status); if (U_SUCCESS(status)) { break; } - /* FALLTHRU */ + TCL_FALLTHROUGH(); default: Tcl_DStringFree(dsOutPtr); ucnv_close(ucnvPtr); return IcuError(interp, "ICU error while decoding", status); } @@ -972,11 +972,11 @@ normLen = unorm2_normalize( normalizer, utf16, (int)utf16len, normPtr, normLen, &status); if (U_SUCCESS(status)) { break; } - /* FALLTHRU */ + TCL_FALLTHROUGH(); default: Tcl_DStringFree(dsOutPtr); return IcuError(interp, "String normalization failed", status); } } @@ -1035,10 +1035,12 @@ case OPT_FAILINDEX: /* TBD */ Tcl_SetObjResult(interp, Tcl_NewStringObj("Option -failindex not implemented.", TCL_INDEX_NONE)); return TCL_ERROR; + default: + TCL_UNREACHABLE(); } } *strictPtr = strict; *failindexVarPtr = NULL; return TCL_OK; @@ -1203,10 +1205,12 @@ case OPT_MODE: if (Tcl_GetIndexFromObj(interp, objv[i], normalizationForms, "normalization mode", 0, &mode) != TCL_OK) { return TCL_ERROR; } break; + default: + TCL_UNREACHABLE(); } } Tcl_DString dsIn; Tcl_DString dsNorm; @@ -1357,11 +1361,12 @@ }; /* 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; #else i = 0; Index: generic/tclIndexObj.c ================================================================== --- generic/tclIndexObj.c +++ generic/tclIndexObj.c @@ -53,11 +53,11 @@ * Keep this structure declaration in sync with tclTestObj.c */ 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; /* * The following macros greatly simplify moving through a table... @@ -301,24 +301,24 @@ uncachedDone: if (indexPtr != NULL) { flags &= (30-(int)(sizeof(int)<<1)); if (flags) { if (flags == sizeof(uint16_t)<<1) { - *(uint16_t *)indexPtr = (uint16_t)index; + *(uint16_t *)indexPtr = index; return TCL_OK; } else if (flags == (int)(sizeof(uint8_t)<<1)) { - *(uint8_t *)indexPtr = (uint8_t)index; + *(uint8_t *)indexPtr = 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 = (int32_t)index; + *(int32_t *)indexPtr = index; return TCL_OK; } } - *(int *)indexPtr = (int)index; + *(int *)indexPtr = index; } return TCL_OK; error: if (interp != NULL) { @@ -386,12 +386,13 @@ UpdateStringOfIndex( Tcl_Obj *objPtr) { 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); } /* *---------------------------------------------------------------------- * @@ -804,11 +805,11 @@ */ 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 * objects in objv. The message may be * NULL. */ @@ -1007,17 +1008,17 @@ * of argument descriptions. */ const Tcl_ArgvInfo *matchPtr; /* 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. */ Tcl_Size length; /* Number of characters in current argument */ Tcl_Size gf_ret; /* Return value from Tcl_ArgvGenFuncProc*/ @@ -1105,11 +1106,11 @@ gotMatch: infoPtr = matchPtr; switch (infoPtr->type) { case TCL_ARGV_CONSTANT: - *((int *)infoPtr->dstPtr) = (int)PTR2INT(infoPtr->srcPtr); + *((int *) infoPtr->dstPtr) = PTR2INT(infoPtr->srcPtr); break; case TCL_ARGV_INT: if (objc == 0) { goto missingArg; } @@ -1137,19 +1138,19 @@ * Only store the point where we got to if it's not to be written * to NULL, so that TCL_ARGV_AUTO_REST works. */ if (infoPtr->dstPtr != NULL) { - *((int *)infoPtr->dstPtr) = (int)dstIndex; + *((int *) infoPtr->dstPtr) = dstIndex; } goto argsDone; case TCL_ARGV_FLOAT: if (objc == 0) { 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]))); goto error; } @@ -1266,11 +1267,11 @@ const Tcl_ArgvInfo *argTable) /* Array of command-specific argument * descriptions. */ { const Tcl_ArgvInfo *infoPtr; - Tcl_Size width, numSpaces; + int width, numSpaces; #define NUM_SPACES 20 static const char spaces[] = " "; Tcl_Obj *msg; /* Index: generic/tclInt.decls ================================================================== --- generic/tclInt.decls +++ generic/tclInt.decls @@ -156,16 +156,21 @@ Tcl_Obj *TclNewProcBodyObj(Proc *procPtr) } 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(size_t size) + void *TclpAlloc(TCL_HASH_TYPE size) } declare 74 { void TclpFree(void *ptr) } declare 75 { @@ -177,11 +182,11 @@ # Removed in 9.0: #declare 77 { # void TclpGetTime(Tcl_Time *time) #} declare 81 { - void *TclpRealloc(void *ptr, size_t size) + void *TclpRealloc(void *ptr, TCL_HASH_TYPE size) } # Removed in 9.0: #declare 88 { # char *TclPrecTraceProc(void *clientData, Tcl_Interp *interp, # const char *name1, const char *name2, int flags) @@ -458,11 +463,11 @@ } declare 214 { void TclSetObjNameOfExecutable(Tcl_Obj *name, Tcl_Encoding encoding) } declare 215 { - void *TclStackAlloc(Tcl_Interp *interp, size_t numBytes) + void *TclStackAlloc(Tcl_Interp *interp, TCL_HASH_TYPE numBytes) } declare 216 { void TclStackFree(Tcl_Interp *interp, void *freePtr) } declare 217 { @@ -633,10 +638,13 @@ } 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) } Index: generic/tclInt.h ================================================================== --- generic/tclInt.h +++ generic/tclInt.h @@ -139,10 +139,36 @@ # define Tcl_ConditionWait(condPtr, mutexPtr, timePtr) # undef Tcl_ConditionFinalize # 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. */ @@ -216,12 +242,14 @@ */ 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; /* * Define this to reduce the amount of space that the average namespace * consumes by only allocating the table of child namespaces when necessary. @@ -260,11 +288,15 @@ Tcl_HashTable *childTablePtr; /* Contains any child namespaces. Indexed by * 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 * flags NS_DYING and NS_DEAD listed below. */ Tcl_Size activationCount; /* Number of "activations" or active call @@ -743,10 +775,12 @@ #define VAR_ARGUMENT 0x100 /* KEEP OLD VALUE! See tclProc.c */ #define VAR_TEMPORARY 0x200 /* KEEP OLD VALUE! See tclProc.c */ #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: * * MODULE_SCOPE void TclSetVarScalar(Var *varPtr); @@ -959,10 +993,13 @@ * local. */ Tcl_Size nameLength; /* The number of bytes in local variable's name. * 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. */ Tcl_ResolvedVarInfo *resolveInfo; /* Customized variable resolution info @@ -969,14 +1006,16 @@ * supplied by the Tcl_ResolveCompiledVarProc * associated with a namespace. Each variable * 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 * enough to hold the name. MUST BE THE LAST * FIELD IN THE STRUCTURE! */ @@ -1030,11 +1069,15 @@ */ 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 * Tcl_CreateObjTrace for details. */ Tcl_CmdObjTraceDeleteProc *delProc; @@ -1074,10 +1117,11 @@ */ #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))) ? \ ((objPtr)->typePtr)->proc : NULL) @@ -1175,10 +1219,11 @@ int *boolResult) { 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 * associated with an interpreter. The entry contains a pointer to a function * to call when the interpreter is deleted, and a pointer to a user-defined @@ -1669,17 +1714,17 @@ * points to first entry in bucket's hash * chain, or NULL. */ LiteralEntry *staticBuckets[TCL_SMALL_HASH_TABLE]; /* Bucket array used for small tables to avoid * mallocs and frees. */ - size_t numBuckets; /* Total number of buckets allocated at + TCL_HASH_TYPE numBuckets; /* Total number of buckets allocated at * **buckets. */ - size_t numEntries; /* Total number of entries present in + TCL_HASH_TYPE numEntries; /* Total number of entries present in * table. */ - size_t rebuildSize; /* Enlarge table when numEntries gets to be + TCL_HASH_TYPE rebuildSize; /* Enlarge table when numEntries gets to be * this large. */ - size_t mask; /* Mask value used in hashing function. */ + TCL_HASH_TYPE mask; /* Mask value used in hashing function. */ } LiteralTable; /* * The following structure defines for each Tcl interpreter various * statistics-related information about the bytecode compiler and @@ -1969,13 +2014,24 @@ * of hidden commands on a per-interp * basis. */ 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. */ @@ -2000,10 +2056,15 @@ CallFrame *rootFramePtr; /* Global frame pointer for this * interpreter. */ 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. */ @@ -2023,10 +2084,13 @@ * has been called for this interpreter. */ int evalFlags; /* Flags to control next call to Tcl_Eval. * 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 * string representations of literals. Used to * avoid creating duplicate objects. */ @@ -2059,10 +2123,13 @@ * evaluation stack. */ Tcl_Obj *emptyObjPtr; /* Points to an object holding an empty * 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. */ Tcl_ThreadId threadId; /* ID of thread that owns the interpreter. */ @@ -2426,11 +2493,11 @@ */ #if defined(__APPLE__) #define TCL_ALLOCALIGN 16 #else -#define TCL_ALLOCALIGN (2*(int)sizeof(void *)) +#define TCL_ALLOCALIGN (2*sizeof(void *)) #endif /* * TCL_ALIGN is used to determine the offset needed to safely allocate any * data structure in memory. Given a starting offset or size, it "rounds up" @@ -2722,15 +2789,24 @@ * and Tcl_GetIntForIndex. * * 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) \ ((TclHasInternalRep((objPtr), &tclIntType)) \ ? ((*(longPtr) = (objPtr)->internalRep.wideValue), TCL_OK) \ @@ -2864,11 +2940,11 @@ * Data structures for process-global values. *---------------------------------------------------------------- */ typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, - size_t *lengthPtr, + TCL_HASH_TYPE *lengthPtr, Tcl_Encoding *encodingPtr); #ifdef _WIN32 /* On Windows, all Unicode (except surrogates) are valid. */ # define TCLFSENCODING tclUtf8Encoding @@ -2886,11 +2962,11 @@ */ typedef struct ProcessGlobalValue { Tcl_Size epoch; /* Epoch counter to detect changes in the * global value. */ - size_t numBytes; /* Length of the global string. */ + TCL_HASH_TYPE numBytes; /* Length of the global string. */ char *value; /* The global string value. */ Tcl_Encoding encoding; /* system encoding when global string was * initialized. */ TclInitProcessGlobalValueProc *proc; /* A procedure to initialize the global string @@ -3065,11 +3141,20 @@ const char *profileName, int *profilePtr); 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. */ @@ -3226,10 +3311,11 @@ *---------------------------------------------------------------- * Procedures shared among Tcl modules but not used by the outside world: *---------------------------------------------------------------- */ +#if TCL_MAJOR_VERSION > 8 MODULE_SCOPE void TclAdvanceContinuations(Tcl_Size *line, Tcl_Size **next, int loc); MODULE_SCOPE void TclAdvanceLines(Tcl_Size *line, const char *start, const char *end); MODULE_SCOPE void TclAppendBytesToByteArray(Tcl_Obj *objPtr, @@ -3500,14 +3586,14 @@ struct addrinfo **addrlist, const char *host, int port, int willBind, const char **errorMsgPtr); MODULE_SCOPE int TclpThreadCreate(Tcl_ThreadId *idPtr, Tcl_ThreadCreateProc *proc, void *clientData, - size_t stackSize, int flags); + TCL_HASH_TYPE stackSize, int flags); MODULE_SCOPE Tcl_Size TclpFindVariable(const char *name, Tcl_Size *lengthPtr); MODULE_SCOPE void TclpInitLibraryPath(char **valuePtr, - size_t *lengthPtr, Tcl_Encoding *encodingPtr); + TCL_HASH_TYPE *lengthPtr, Tcl_Encoding *encodingPtr); MODULE_SCOPE void TclpInitLock(void); MODULE_SCOPE void * TclpInitNotifier(void); MODULE_SCOPE void TclpInitPlatform(void); MODULE_SCOPE void TclpInitUnlock(void); MODULE_SCOPE Tcl_Obj * TclpObjListVolumes(void); @@ -3567,11 +3653,11 @@ MODULE_SCOPE void TclSignalExitThread(Tcl_ThreadId id, int result); 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, - size_t numBytes); + TCL_HASH_TYPE 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); MODULE_SCOPE int TclStringMatch(const char *str, Tcl_Size strLen, const char *pattern, int ptnLen, int flags); @@ -3654,11 +3740,11 @@ * optimization (fragile on changes) in one place. */ MODULE_SCOPE int TclIsSpaceProc(int byte); #define TclIsSpaceProcM(byte) \ - (((byte) > 0x20) ? 0 : TclIsSpaceProc(byte)) + (((unsigned)(byte) > 0x20) ? 0 : TclIsSpaceProc(byte)) /* *---------------------------------------------------------------- * Command procedures in the generic core: *---------------------------------------------------------------- @@ -3961,13 +4047,14 @@ Tcl_Size first, Tcl_Size count, Tcl_Obj *insertPtr, int flags); 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 * by the bytecode compiler and engine. Some of these could later be placed in * the public interface. @@ -4016,11 +4103,11 @@ * So tclObj.c and tclDictObj.c can share these implementations. */ MODULE_SCOPE int TclCompareObjKeys(void *keyPtr, Tcl_HashEntry *hPtr); MODULE_SCOPE void TclFreeObjEntry(Tcl_HashEntry *hPtr); -MODULE_SCOPE size_t TclHashObjKey(Tcl_HashTable *tablePtr, void *keyPtr); +MODULE_SCOPE TCL_HASH_TYPE TclHashObjKey(Tcl_HashTable *tablePtr, void *keyPtr); MODULE_SCOPE int TclFullFinalizationRequested(void); /* * TIP #542 @@ -4092,10 +4179,11 @@ * Error message utility functions */ 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) #define TCL_INDEX_START ((Tcl_Size)0) @@ -4366,11 +4454,11 @@ * * The ANSI C "prototypes" for these macros are: * * 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); * *---------------------------------------------------------------- */ #define TclInitEmptyStringRep(objPtr) \ @@ -4391,11 +4479,11 @@ TclInitEmptyStringRep(objPtr) \ ) : ( \ (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) /* *---------------------------------------------------------------- * Macro used by the Tcl core to get the string representation's byte array @@ -4494,11 +4582,11 @@ #define TclUnpackBignum(objPtr, bignum) \ 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 { \ (bignum).dp = (mp_digit *)bignumObj->internalRep.twoPtrValue.ptr1; \ (bignum).sign = bignumPayload >> 30; \ Index: generic/tclIntDecls.h ================================================================== --- generic/tclIntDecls.h +++ generic/tclIntDecls.h @@ -169,11 +169,11 @@ /* Slot 65 is reserved */ /* Slot 66 is reserved */ /* Slot 67 is reserved */ /* Slot 68 is reserved */ /* 69 */ -EXTERN void * TclpAlloc(size_t size); +EXTERN void * TclpAlloc(TCL_HASH_TYPE size); /* Slot 70 is reserved */ /* Slot 71 is reserved */ /* Slot 72 is reserved */ /* Slot 73 is reserved */ /* 74 */ @@ -185,11 +185,11 @@ /* Slot 77 is reserved */ /* Slot 78 is reserved */ /* Slot 79 is reserved */ /* Slot 80 is reserved */ /* 81 */ -EXTERN void * TclpRealloc(void *ptr, size_t size); +EXTERN void * TclpRealloc(void *ptr, TCL_HASH_TYPE size); /* Slot 82 is reserved */ /* Slot 83 is reserved */ /* Slot 84 is reserved */ /* Slot 85 is reserved */ /* Slot 86 is reserved */ @@ -438,11 +438,12 @@ EXTERN Tcl_Obj * TclGetObjNameOfExecutable(void); /* 214 */ EXTERN void TclSetObjNameOfExecutable(Tcl_Obj *name, Tcl_Encoding encoding); /* 215 */ -EXTERN void * TclStackAlloc(Tcl_Interp *interp, size_t numBytes); +EXTERN void * TclStackAlloc(Tcl_Interp *interp, + TCL_HASH_TYPE numBytes); /* 216 */ EXTERN void TclStackFree(Tcl_Interp *interp, void *freePtr); /* 217 */ EXTERN int TclPushStackFrame(Tcl_Interp *interp, Tcl_CallFrame **framePtrPtr, @@ -567,11 +568,12 @@ /* 257 */ 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 */ EXTERN void TclUnusedStubEntry(void); @@ -646,11 +648,11 @@ int (*tclObjInvoke) (Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[], int flags); /* 64 */ void (*reserved65)(void); void (*reserved66)(void); void (*reserved67)(void); void (*reserved68)(void); - void * (*tclpAlloc) (size_t size); /* 69 */ + void * (*tclpAlloc) (TCL_HASH_TYPE size); /* 69 */ void (*reserved70)(void); void (*reserved71)(void); void (*reserved72)(void); void (*reserved73)(void); void (*tclpFree) (void *ptr); /* 74 */ @@ -658,11 +660,11 @@ unsigned long long (*tclpGetSeconds) (void); /* 76 */ void (*reserved77)(void); void (*reserved78)(void); void (*reserved79)(void); void (*reserved80)(void); - void * (*tclpRealloc) (void *ptr, size_t size); /* 81 */ + void * (*tclpRealloc) (void *ptr, TCL_HASH_TYPE size); /* 81 */ void (*reserved82)(void); void (*reserved83)(void); void (*reserved84)(void); void (*reserved85)(void); void (*reserved86)(void); @@ -792,11 +794,11 @@ void (*reserved210)(void); void (*reserved211)(void); 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, size_t numBytes); /* 215 */ + void * (*tclStackAlloc) (Tcl_Interp *interp, TCL_HASH_TYPE 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 */ Tcl_Obj * (*tclpCreateTemporaryDirectory) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj); /* 219 */ void (*reserved220)(void); @@ -835,11 +837,11 @@ Tcl_Obj * (*tclPtrSetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, int flags); /* 253 */ Tcl_Obj * (*tclPtrIncrObjVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, int flags); /* 254 */ 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 */ } TclIntStubs; @@ -1250,11 +1252,12 @@ (tclIntStubsPtr->tclPtrObjMakeUpvar) /* 255 */ #define TclPtrUnsetVar \ (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 \ (tclIntStubsPtr->tclUnusedStubEntry) /* 261 */ @@ -1265,14 +1268,25 @@ #if defined(USE_TCL_STUBS) #undef Tcl_StaticLibrary #define Tcl_StaticLibrary \ (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() #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT #endif /* _TCLINTDECLS */ Index: generic/tclIntPlatDecls.h ================================================================== --- generic/tclIntPlatDecls.h +++ generic/tclIntPlatDecls.h @@ -28,10 +28,496 @@ * WARNING: This file is automatically generated by the tools/genStubs.tcl * script. Any modifications to the function declarations below should be made * 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 extern "C" { #endif @@ -200,10 +686,11 @@ (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */ #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 #ifdef MAC_OSX_TCL /* not accessible on Win32/UNIX */ Index: generic/tclInterp.c ================================================================== --- generic/tclInterp.c +++ generic/tclInterp.c @@ -338,12 +338,12 @@ /* * Splice for putting the "tcl" package in the list of packages while the * 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. */ } PkgName; @@ -754,10 +754,12 @@ flags |= TCL_CANCEL_UNWIND; break; case OPT_LAST: i++; goto endOfForLoop; + default: + TCL_UNREACHABLE(); } } endOfForLoop: if (i < objc - 2) { @@ -1020,12 +1022,11 @@ case LIMIT_TYPE_COMMANDS: return ChildCommandLimitCmd(interp, childInterp, 4, objc,objv); case LIMIT_TYPE_TIME: return ChildTimeLimitCmd(interp, childInterp, 4, objc, objv); default: - Tcl_Panic("unreachable"); - return TCL_ERROR; + TCL_UNREACHABLE(); } } case OPT_MARKTRUSTED: if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "path"); @@ -1145,12 +1146,11 @@ return TCL_ERROR; } return TCL_OK; } default: - Tcl_Panic("unreachable"); - return TCL_ERROR; + TCL_UNREACHABLE(); } } /* *--------------------------------------------------------------------------- @@ -2675,13 +2675,14 @@ switch (limitType) { case LIMIT_TYPE_COMMANDS: 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); return TCL_ERROR; } @@ -2690,10 +2691,12 @@ if (objc != 2 && objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "?newlimit?"); return TCL_ERROR; } return ChildRecursionLimit(interp, childInterp, objc - 2, objv + 2); + default: + TCL_UNREACHABLE(); } return TCL_ERROR; } @@ -3960,11 +3963,11 @@ * None. * *---------------------------------------------------------------------- */ -Tcl_Size +int Tcl_LimitGetCommands( Tcl_Interp *interp) { Interp *iPtr = (Interp *) interp; @@ -4327,11 +4330,11 @@ hashPtr = Tcl_FirstHashEntry(&iPtr->limit.callbacks, &search); while (hashPtr != NULL) { keyPtr = (ScriptLimitCallbackKey *) Tcl_GetHashKey(&iPtr->limit.callbacks, hashPtr); - Tcl_LimitRemoveHandler(keyPtr->interp, (int)keyPtr->type, + Tcl_LimitRemoveHandler(keyPtr->interp, keyPtr->type, CallScriptLimitCallback, Tcl_GetHashValue(hashPtr)); hashPtr = Tcl_NextHashEntry(&search); } Tcl_DeleteHashTable(&iPtr->limit.callbacks); } @@ -4527,10 +4530,12 @@ if (Tcl_LimitTypeEnabled(childInterp, TCL_LIMIT_COMMANDS)) { Tcl_SetObjResult(interp, Tcl_NewWideIntObj(Tcl_LimitGetCommands(childInterp))); } break; + default: + TCL_UNREACHABLE(); } return TCL_OK; } else if ((objc-consumedObjc) & 1 /* isOdd(objc-consumedObjc) */) { Tcl_WrongNumArgs(interp, consumedObjc, objv, "?-option value ...?"); return TCL_ERROR; @@ -4577,10 +4582,12 @@ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "BADVALUE", (char *)NULL); return TCL_ERROR; } break; + default: + TCL_UNREACHABLE(); } } if (scriptObj != NULL) { SetScriptLimitCallback(interp, TCL_LIMIT_COMMANDS, childInterp, (scriptLen > 0 ? scriptObj : NULL)); @@ -4727,10 +4734,12 @@ Tcl_LimitGetTime(childInterp, &limitMoment); Tcl_SetObjResult(interp, Tcl_NewWideIntObj(limitMoment.sec)); } break; + default: + TCL_UNREACHABLE(); } return TCL_OK; } else if ((objc-consumedObjc) & 1 /* isOdd(objc-consumedObjc) */) { Tcl_WrongNumArgs(interp, consumedObjc, objv, "?-option value ...?"); return TCL_ERROR; @@ -4800,10 +4809,12 @@ "BADVALUE", (char *)NULL); return TCL_ERROR; } limitMoment.sec = (long long) tmp; break; + default: + TCL_UNREACHABLE(); } } if (milliObj != NULL || secObj != NULL) { if (milliObj != NULL) { /* Index: generic/tclLink.c ================================================================== --- generic/tclLink.c +++ generic/tclLink.c @@ -34,11 +34,11 @@ * via upvar. */ void *addr; /* Location of C variable. */ 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 { char c; unsigned char uc; @@ -678,11 +678,11 @@ *---------------------------------------------------------------------- */ 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*/, /* Links can only be made to global variables, * so we can find them with need to resolve @@ -1314,11 +1314,11 @@ } linkPtr->lastValue.uw = LinkedVar(Tcl_WideUInt); Tcl_Obj *uwObj; TclNewUIntObj(uwObj, linkPtr->lastValue.uw); return uwObj; - } + } case TCL_LINK_STRING: p = LinkedVar(char *); if (p == NULL) { TclNewLiteralStringObj(resultObj, "NULL"); Index: generic/tclListObj.c ================================================================== --- generic/tclListObj.c +++ generic/tclListObj.c @@ -237,12 +237,12 @@ * *------------------------------------------------------------------------ */ 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; spanPtr->spanStart = firstSlot; spanPtr->spanLength = numSlots; @@ -296,12 +296,12 @@ * *------------------------------------------------------------------------ */ 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 */ { /* * Possible optimizations for future consideration * - heuristic LIST_SPAN_THRESHOLD @@ -368,13 +368,13 @@ * *------------------------------------------------------------------------ */ 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); LIST_COUNT_ASSERT(count); objv += startIdx; @@ -400,13 +400,13 @@ * *------------------------------------------------------------------------ */ 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); LIST_COUNT_ASSERT(count); objv += startIdx; @@ -432,13 +432,13 @@ * *------------------------------------------------------------------------ */ 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); end = to + count; /* TODO - would memmove followed by separate IncrRef loop be faster? */ @@ -463,12 +463,12 @@ * *------------------------------------------------------------------------ */ 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( "list construction failed: unable to alloc %" TCL_Z_MODIFIER "u bytes", @@ -1256,14 +1256,14 @@ *---------------------------------------------------------------------- */ 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; result = SetListFromAny(interp, listObj); if (result != TCL_OK) { @@ -1458,11 +1458,11 @@ /* 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 */ } 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); /* Assert: Because numSrcElems > rangeEnd earlier */ if (numAfterRangeEnd != 0) { @@ -2015,13 +2015,13 @@ */ #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; /* Empty string => empty list. Avoid unnecessary shimmering */ if (listObj->bytes == &tclEmptyString) { @@ -2662,18 +2662,18 @@ { int status; 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 */ for (i=0 ; i error. */ + /* The list is not a list at all => error. */ Tcl_DecrRefCount(listObj); return NULL; } } @@ -2782,14 +2790,14 @@ Tcl_Interp *interp, /* Tcl interpreter. */ Tcl_Obj *listObj, /* Pointer to the list being modified. */ 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; /* * Determine whether the index arg designates a list or a single index. * We have to be careful about the order of the checks to avoid repeated @@ -3155,11 +3163,11 @@ Tcl_Size index, /* Index of element to store. */ Tcl_Obj *valueObj) /* Tcl object to store in the designated list * 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. */ if (Tcl_IsShared(listObj)) { Index: generic/tclLiteral.c ================================================================== --- generic/tclLiteral.c +++ generic/tclLiteral.c @@ -27,13 +27,13 @@ /* * Function prototypes for static functions in this file: */ static size_t AddLocalLiteralEntry(CompileEnv *envPtr, - Tcl_Obj *objPtr, size_t localHash); + Tcl_Obj *objPtr, int localHash); static void ExpandLocalLiteralArray(CompileEnv *envPtr); -static size_t HashString(const char *string, Tcl_Size length); +static size_t HashString(const char *string, size_t length); #ifdef TCL_COMPILE_DEBUG static LiteralEntry * LookupLiteralEntry(Tcl_Interp *interp, Tcl_Obj *objPtr); #endif static void RebuildLiteralTable(LiteralTable *tablePtr); @@ -56,11 +56,12 @@ *---------------------------------------------------------------------- */ 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) Tcl_Panic("%s: TCL_SMALL_HASH_TABLE is %d, not 4", "TclInitLiteralTable", TCL_SMALL_HASH_TABLE); @@ -173,15 +174,15 @@ */ 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, LiteralEntry **globalPtrPtr) { @@ -386,16 +387,16 @@ *---------------------------------------------------------------------- */ 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 * malloc'd bytes and ownership is passed to * this function. If LITERAL_CMD_NAME then @@ -437,11 +438,11 @@ #endif /*TCL_COMPILE_DEBUG*/ if (objIndex > INT_MAX) { Tcl_Panic("Literal table index too large. Cannot be handled by TclEmitPush"); } - return (int)objIndex; + return objIndex; } } /* * The literal is new to this CompileEnv. If it is a command name, avoid @@ -479,11 +480,11 @@ #endif /*TCL_COMPILE_DEBUG*/ if (objIndex > INT_MAX) { Tcl_Panic( "Literal table index too large. Cannot be handled by TclEmitPush"); } - return (int)objIndex; + return objIndex; } #ifdef TCL_COMPILE_DEBUG /* *---------------------------------------------------------------------- @@ -644,11 +645,11 @@ if (litPtrPtr) { *litPtrPtr = lPtr; } - return (int)objIndex; + return objIndex; } /* *---------------------------------------------------------------------- * @@ -670,11 +671,11 @@ static size_t 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. */ - size_t localHash) /* Hash value for the literal's string. */ + int localHash) /* Hash value for the literal's string. */ { LiteralTable *localTablePtr = &envPtr->localLitTable; LiteralEntry *localPtr; size_t objIndex; @@ -908,12 +909,12 @@ *---------------------------------------------------------------------- */ static size_t HashString( - const char *string, /* String for which to compute hash value. */ - Tcl_Size 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; /* * I tried a zillion different hash functions and asked many other people @@ -972,11 +973,12 @@ *---------------------------------------------------------------------- */ static void RebuildLiteralTable( - LiteralTable *tablePtr) /* Local or global table to enlarge. */ + LiteralTable *tablePtr) + /* Local or global table to enlarge. */ { LiteralEntry **oldBuckets; LiteralEntry **oldChainPtr, **newChainPtr; LiteralEntry *entryPtr; LiteralEntry **bucketPtr; Index: generic/tclLoad.c ================================================================== --- generic/tclLoad.c +++ generic/tclLoad.c @@ -154,17 +154,18 @@ } if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, &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)) { Tcl_WrongNumArgs(interp, 1, savedobjv, "?-global? ?-lazy? ?--? fileName ?prefix? ?interp?"); @@ -596,10 +597,12 @@ keepLibrary = 1; break; case UNLOAD_LAST: /* -- */ i++; goto endOfForLoop; + default: + TCL_UNREACHABLE(); } } endOfForLoop: if ((objc-i < 1) || (objc-i > 3)) { Tcl_WrongNumArgs(interp, 1, objv, Index: generic/tclMain.c ================================================================== --- generic/tclMain.c +++ generic/tclMain.c @@ -274,11 +274,11 @@ *---------------------------------------------------------------------- */ 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 * function to call after most initialization * but before starting to execute commands. */ @@ -733,11 +733,11 @@ *---------------------------------------------------------------------- */ 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; Tcl_Size length; InteractiveState *isPtr = (InteractiveState *)clientData; Index: generic/tclNamesp.c ================================================================== --- generic/tclNamesp.c +++ generic/tclNamesp.c @@ -2026,11 +2026,12 @@ * Original not in namespace we're matching. Check the first link * in the import chain. */ Command *cmdPtr = (Command *) token; - ImportedCmdData *dataPtr = (ImportedCmdData *)cmdPtr->objClientData; + ImportedCmdData *dataPtr = (ImportedCmdData *) + cmdPtr->objClientData; Tcl_Command firstToken = (Tcl_Command) dataPtr->realCmdPtr; if (firstToken == origin) { continue; } @@ -2299,11 +2300,11 @@ * the actual namespace from which the search * started. This is either cxtNsPtr, the :: * 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. */ { Interp *iPtr = (Interp *) interp; @@ -3741,12 +3742,11 @@ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { const char *pattern; - int i; - int result; + int i, result; if (objc < 1) { Tcl_WrongNumArgs(interp, 1, objv, "?pattern pattern...?"); return TCL_ERROR; } @@ -3808,12 +3808,12 @@ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { int allowOverwrite = 0; const char *string, *pattern; - int i, firstArg; - int result; + int i, result; + int firstArg; if (objc < 1) { Tcl_WrongNumArgs(interp, 1, objv, "?-force? ?pattern pattern...?"); return TCL_ERROR; } @@ -4768,27 +4768,27 @@ } } 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); if (var != NULL) { Tcl_GetVariableFullName(interp, var, resultPtr); } break; - } + default: + TCL_UNREACHABLE(); } Tcl_SetObjResult(interp, resultPtr); return TCL_OK; } @@ -5018,11 +5018,11 @@ * command (must be <= command). */ const char *command, /* First character in command that generated * 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 */ { const char *p; Interp *iPtr = (Interp *) interp; Index: generic/tclNotify.c ================================================================== --- generic/tclNotify.c +++ generic/tclNotify.c @@ -72,11 +72,11 @@ int initialized; /* 1 if notifier has been initialized. */ EventSource *firstEventSourcePtr; /* 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. * Access is controlled by the listLock global * mutex. */ @@ -306,11 +306,11 @@ /* Function to invoke to figure out what to * wait for. */ 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); EventSource *sourcePtr = (EventSource *)Tcl_Alloc(sizeof(EventSource)); @@ -345,11 +345,11 @@ /* Function to invoke to figure out what to * wait for. */ 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); EventSource *sourcePtr, *prevPtr; @@ -392,11 +392,11 @@ Tcl_Event *evPtr, /* Event to add to queue. The storage space * must have been allocated the caller with * malloc (Tcl_Alloc), and it becomes the * property of the event queue. It will be * freed after the event has been handled. */ - int position) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, TCL_QUEUE_MARK, + int position) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, TCL_QUEUE_MARK, * possibly combined with TCL_QUEUE_ALERT_IF_EMPTY. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); QueueEvent(tsdPtr, evPtr, position); @@ -424,11 +424,11 @@ Tcl_Event *evPtr, /* Event to add to queue. The storage space * must have been allocated the caller with * malloc (Tcl_Alloc), and it becomes the * property of the event queue. It will be * freed after the event has been handled. */ - int position) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, TCL_QUEUE_MARK, + int position) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, TCL_QUEUE_MARK, * possibly combined with TCL_QUEUE_ALERT_IF_EMPTY. */ { ThreadSpecificData *tsdPtr; /* @@ -484,11 +484,11 @@ Tcl_Event *evPtr, /* Event to add to queue. The storage space * must have been allocated the caller with * malloc (Tcl_Alloc), and it becomes the * property of the event queue. It will be * freed after the event has been handled. */ - int position) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, TCL_QUEUE_MARK, + int position) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, TCL_QUEUE_MARK, * possibly combined with TCL_QUEUE_ALERT_IF_EMPTY */ { int wasEmpty = 0; Tcl_MutexLock(&(tsdPtr->queueMutex)); @@ -560,11 +560,11 @@ */ 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 * evPtr designates the first event in the * queue for the thread. */ @@ -1268,11 +1268,11 @@ *---------------------------------------------------------------------- */ void Tcl_AlertNotifier( - void *clientData) /* Pointer to thread data. */ + void *clientData) /* Pointer to thread data. */ { if (tclNotifierHooks.alertNotifierProc) { tclNotifierHooks.alertNotifierProc(clientData); } else { TclpAlertNotifier(clientData); @@ -1325,11 +1325,11 @@ *---------------------------------------------------------------------- */ 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); } else { TclpSetTimer(timePtr); @@ -1356,11 +1356,11 @@ *---------------------------------------------------------------------- */ 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); } else { return TclpWaitForEvent(timePtr); @@ -1395,11 +1395,11 @@ * TCL_WRITABLE, and TCL_EXCEPTION: indicates * conditions under which proc should be * 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); } else { TclpCreateFileHandler(fd, mask, proc, clientData); Index: generic/tclOO.h ================================================================== --- generic/tclOO.h +++ generic/tclOO.h @@ -60,12 +60,16 @@ * and to allow the attachment of arbitrary data to objects and classes. */ 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); typedef void (Tcl_ObjectMetadataDeleteProc)(void *clientData); typedef int (Tcl_ObjectMapMethodNameProc)(Tcl_Interp *interp, @@ -92,10 +96,11 @@ Tcl_CloneProc *cloneProc; /* How to copy this method's type-specific * data, or NULL if the type-specific data can * 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 * declarations. */ const char *name; /* Name of this type of method, mostly for @@ -108,10 +113,13 @@ * does not need deleting. */ Tcl_CloneProc *cloneProc; /* How to copy this method's type-specific * 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. * This allows new versions of the structure to be introduced without breaking * binary compatibility. Index: generic/tclOOBasic.c ================================================================== --- generic/tclOOBasic.c +++ generic/tclOOBasic.c @@ -1205,17 +1205,11 @@ if (mPtr->declaringClassPtr != NULL) { declarerPtr = mPtr->declaringClassPtr->thisPtr; } 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] = TclOOObjectName(interp, callerPtr->oPtr); if (callerPtr->callPtr->flags & CONSTRUCTOR) { @@ -1237,17 +1231,11 @@ if (mPtr->declaringClassPtr != NULL) { declarerPtr = mPtr->declaringClassPtr->thisPtr; } 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); if (contextPtr->callPtr->flags & CONSTRUCTOR) { result[1] = declarerPtr->fPtr->constructorName; @@ -1282,17 +1270,11 @@ if (mPtr->declaringClassPtr != NULL) { declarerPtr = mPtr->declaringClassPtr->thisPtr; } 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; Tcl_SetObjResult(interp, Tcl_NewListObj(2, result)); return TCL_OK; @@ -1300,12 +1282,13 @@ case SELF_CALL: result[0] = TclOORenderCallChain(interp, contextPtr->callPtr); TclNewIndexObj(result[1], contextPtr->index); Tcl_SetObjResult(interp, Tcl_NewListObj(2, result)); return TCL_OK; + default: + TCL_UNREACHABLE(); } - return TCL_ERROR; } /* * ---------------------------------------------------------------------- * Index: generic/tclOOCall.c ================================================================== --- generic/tclOOCall.c +++ generic/tclOOCall.c @@ -1645,10 +1645,11 @@ default: FOREACH(superPtr, clsPtr->superclasses) { AddClassFiltersToCallContext(oPtr, superPtr, cbPtr, doneFilters, flags); } + TCL_FALLTHROUGH(); case 0: return; } } @@ -1732,11 +1733,11 @@ if (AddPrivatesFromClassChainToCallContext(superPtr, contextCls, methodName, cbPtr, doneFilters, flags, filterDecl)) { return 1; } } - /* FALLTHRU */ + TCL_FALLTHROUGH(); case 0: return 0; } } @@ -1827,11 +1828,11 @@ default: FOREACH(superPtr, classPtr->superclasses) { privateDanger |= AddSimpleClassChainToCallContext(superPtr, methodNameObj, cbPtr, doneFilters, flags, filterDecl); } - /* FALLTHRU */ + TCL_FALLTHROUGH(); case 0: return privateDanger; } } @@ -2065,10 +2066,11 @@ goto tailRecurse; default: FOREACH(superPtr, classPtr->superclasses) { AddSimpleClassDefineNamespaces(superPtr, definePtr, flags); } + TCL_FALLTHROUGH(); case 0: return; } } Index: generic/tclOODecls.h ================================================================== --- generic/tclOODecls.h +++ generic/tclOODecls.h @@ -267,7 +267,17 @@ (tclOOStubsPtr->tcl_NewMethod2) /* 34 */ #endif /* defined(USE_TCLOO_STUBS) */ /* !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 */ Index: generic/tclOODefineCmds.c ================================================================== --- generic/tclOODefineCmds.c +++ generic/tclOODefineCmds.c @@ -1736,13 +1736,13 @@ /* * 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) { Tcl_DecrRefCount(*storagePtr); } @@ -2095,10 +2095,12 @@ isPublic = TRUE_PRIVATE_METHOD; break; case MODE_UNEXPORT: isPublic = 0; break; + default: + TCL_UNREACHABLE(); } } else { if (IsPrivateDefine(interp)) { isPublic = TRUE_PRIVATE_METHOD; } else { @@ -2495,10 +2497,11 @@ Tcl_ListObjAppendElement(NULL, resultObj, TclOOObjectName(interp, mixinPtr->thisPtr)); } Tcl_SetObjResult(interp, resultObj); return TCL_OK; + } static int ClassMixin_Set( TCL_UNUSED(void *), Index: generic/tclOOInfo.c ================================================================== --- generic/tclOOInfo.c +++ generic/tclOOInfo.c @@ -483,10 +483,12 @@ if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "objName className"); return TCL_ERROR; } break; + default: + TCL_UNREACHABLE(); } /* * Perform the check. Note that we can guarantee that we will not fail * from here on; "failures" result in a false-TCL_OK result. @@ -536,10 +538,12 @@ } if (o2Ptr->classPtr != NULL) { result = TclOOIsReachable(o2Ptr->classPtr, oPtr->selfCls); } break; + default: + TCL_UNREACHABLE(); } Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result)); return TCL_OK; failPrecondition: @@ -626,10 +630,12 @@ if (Tcl_GetIndexFromObj(interp, objv[i], scopes, "scope", 0, &scope) != TCL_OK) { return TCL_ERROR; } break; + default: + TCL_UNREACHABLE(); } } } if (scope != SCOPE_DEFAULT) { recurse = 0; @@ -1143,13 +1149,13 @@ if (objc == 3 && Tcl_GetIndexFromObj(interp, objv[2], kindList, "kind", 0, &kind) != TCL_OK) { return TCL_ERROR; } - if (kind) { + if (kind) { // -instance nsNamePtr = clsPtr->objDefinitionNs; - } else { + } else { // -class nsNamePtr = clsPtr->clsDefinitionNs; } if (nsNamePtr) { Tcl_SetObjResult(interp, nsNamePtr); } @@ -1410,10 +1416,12 @@ if (Tcl_GetIndexFromObj(interp, objv[i], scopes, "scope", 0, &scope) != TCL_OK) { return TCL_ERROR; } break; + default: + TCL_UNREACHABLE(); } } } if (scope != SCOPE_DEFAULT) { recurse = 0; @@ -1425,10 +1433,12 @@ flag = PUBLIC_METHOD; break; case SCOPE_UNEXPORTED: flag = 0; break; + default: + TCL_UNREACHABLE(); } } TclNewObj(resultObj); if (recurse) { Index: generic/tclOOInt.h ================================================================== --- generic/tclOOInt.h +++ generic/tclOOInt.h @@ -200,11 +200,11 @@ * unique list if not NULL. */ Tcl_Obj *allWritableCache; /* The cache of all writable properties * exposed by this object or class (in its * stereotypical instances). Contains a sorted * unique list if not NULL. */ - Tcl_Size epoch; /* The epoch that the caches are valid for. */ + int epoch; /* The epoch that the caches are valid for. */ }; /* * Now, the definition of what an object actually is. */ @@ -257,11 +257,11 @@ * support. */ }; 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 * the class hierarchy and should be treated * specially during teardown. */ @@ -654,11 +654,11 @@ * memory management of objects. * REQUIRES DECLARATION: Tcl_Size i; */ #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) /* * A variation where the array is an array of structs. There's no issue with @@ -666,11 +666,11 @@ * variable set to a pointer to each of those elements in turn. * REQUIRES DECLARATION: Tcl_Size i; See [96551aca55] for more FOREACH_STRUCT details. */ #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 * sets up the declarations needed for the main macro, FOREACH_HASH, which * does the actual iteration. FOREACH_HASH_KEY and FOREACH_HASH_VALUE are @@ -679,20 +679,20 @@ */ #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)) /* * Convenience macro for duplicating a list. Needs no external declaration, Index: generic/tclOOProp.c ================================================================== --- generic/tclOOProp.c +++ generic/tclOOProp.c @@ -1097,10 +1097,12 @@ if (Tcl_GetIndexFromObj(interp, argObj, kinds, "kind", 0, &kind) != TCL_OK) { return TCL_ERROR; } break; + default: + TCL_UNREACHABLE(); } } /* * Install the property. Note that TclOOInstallStdPropertyImpls @@ -1219,10 +1221,12 @@ writable = 0; break; case PROP_WRITABLE: writable = 1; break; + default: + TCL_UNREACHABLE(); } } /* * Get the properties. @@ -1277,10 +1281,12 @@ writable = 0; break; case PROP_WRITABLE: writable = 1; break; + default: + TCL_UNREACHABLE(); } } /* * Get the properties. Index: generic/tclObj.c ================================================================== --- generic/tclObj.c +++ generic/tclObj.c @@ -75,11 +75,11 @@ * Notice that different structures with the same name appear in other files. * The structure defined below is used in this file only. */ 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 * any. I.e. this table keeps track of * invisible and stripped continuation lines. @@ -1032,13 +1032,13 @@ #ifdef TCL_MEM_DEBUG 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; objPtr->typePtr = NULL; TclInitEmptyStringRep(objPtr); @@ -1160,13 +1160,13 @@ #ifdef TCL_MEM_DEBUG 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; /* @@ -1660,13 +1660,13 @@ #if !defined(TCL_NO_DEPRECATED) #undef TclGetStringFromObj char * TclGetStringFromObj( - Tcl_Obj *objPtr, /* Object whose string rep byte pointer should + Tcl_Obj *objPtr, /* Object whose string rep byte pointer should * be returned. */ - void *lengthPtr) /* If non-NULL, the location where the string + void *lengthPtr) /* If non-NULL, the location where the string * rep's byte array length should * be stored. * If NULL, no length is stored. */ { if (objPtr->bytes == NULL) { /* @@ -1705,11 +1705,11 @@ #endif /* !defined(TCL_NO_DEPRECATED) */ #undef Tcl_GetStringFromObj char * Tcl_GetStringFromObj( - Tcl_Obj *objPtr, /* Object whose string rep byte pointer should + Tcl_Obj *objPtr, /* Object whose string rep byte pointer should * be returned. */ Tcl_Size *lengthPtr) /* If non-NULL, the location where the string * rep's byte array length should * be stored. * If NULL, no length is stored. */ { @@ -1788,11 +1788,11 @@ *---------------------------------------------------------------------- */ 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) { assert(objPtr->bytes == NULL || bytes == NULL); @@ -1859,11 +1859,11 @@ *---------------------------------------------------------------------- */ 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); } @@ -1971,11 +1971,11 @@ *---------------------------------------------------------------------- */ 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); } /* @@ -1998,14 +1998,14 @@ */ #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; if ((flags & TCL_NULL_OK) && (objPtr == NULL || Tcl_GetString(objPtr)[0] == '\0')) { @@ -2050,17 +2050,17 @@ if (flags) { if (flags == (int)sizeof(int)) { *(int *)charPtr = result; return TCL_OK; } else if (flags == (int)sizeof(short)) { - *(short *)charPtr = (short)result; + *(short *)charPtr = result; return TCL_OK; } else { Tcl_Panic("Wrong bool var for %s", "Tcl_GetBoolFromObj"); } } - *charPtr = (char)result; + *charPtr = result; } return TCL_OK; } /* Handle dict separately, because it doesn't have a lengthProc */ if (TclHasInternalRep(objPtr, &tclDictType)) { @@ -2085,13 +2085,13 @@ } #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); } /* @@ -2115,11 +2115,11 @@ */ 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 * whether a boolean conversion is possible without generating the string * rep. @@ -2161,11 +2161,11 @@ return TCL_ERROR; } static int ParseBoolean( - Tcl_Obj *objPtr) /* The object to parse/convert. */ + Tcl_Obj *objPtr) /* The object to parse/convert. */ { int newBool; char lowerCase[6]; Tcl_Size i, length; const char *str = Tcl_GetStringFromObj(objPtr, &length); @@ -2303,20 +2303,20 @@ #ifdef TCL_MEM_DEBUG #undef Tcl_NewDoubleObj 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); } #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * Tcl_NewDoubleObj( - double dblValue) /* Double used to initialize the object. */ + double dblValue) /* Double used to initialize the object. */ { Tcl_Obj *objPtr; TclNewDoubleObj(objPtr, dblValue); return objPtr; @@ -2351,11 +2351,11 @@ #ifdef TCL_MEM_DEBUG 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 * debugging. */ { @@ -2432,13 +2432,13 @@ *---------------------------------------------------------------------- */ 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 { if (TclHasInternalRep(objPtr, &tclDoubleType)) { if (isnan(objPtr->internalRep.doubleValue)) { @@ -2574,13 +2574,13 @@ *---------------------------------------------------------------------- */ 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); #else long l; @@ -2646,11 +2646,11 @@ *---------------------------------------------------------------------- */ 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); TclOOM(dst, TCL_INTEGER_SPACE + 1); (void) Tcl_InitStringRep(objPtr, NULL, @@ -2678,13 +2678,13 @@ *---------------------------------------------------------------------- */ 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 { #ifdef TCL_WIDE_INT_IS_LONG if (TclHasInternalRep(objPtr, &tclIntType)) { @@ -2812,21 +2812,23 @@ #ifdef TCL_MEM_DEBUG #undef 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. */ { return Tcl_DbNewWideIntObj(wideValue, "unknown", 0); } #else /* if not TCL_MEM_DEBUG */ 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; TclNewObj(objPtr); @@ -2850,11 +2852,12 @@ *---------------------------------------------------------------------- */ 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; TclNewUIntObj(objPtr, uwideValue); @@ -2895,11 +2898,12 @@ #ifdef TCL_MEM_DEBUG 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. */ int line) /* Line number in the source file; used for * debugging. */ @@ -2913,11 +2917,12 @@ #else /* if not TCL_MEM_DEBUG */ 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*/) { return Tcl_NewWideIntObj(wideValue); @@ -2942,12 +2947,13 @@ *---------------------------------------------------------------------- */ 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)) { Tcl_Panic("%s called with shared object", "Tcl_SetWideIntObj"); } @@ -2973,12 +2979,13 @@ *---------------------------------------------------------------------- */ 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)) { Tcl_Panic("%s called with shared object", "Tcl_SetWideUIntObj"); } @@ -3015,13 +3022,14 @@ *---------------------------------------------------------------------- */ 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 { if (TclHasInternalRep(objPtr, &tclIntType)) { *wideIntPtr = objPtr->internalRep.wideValue; @@ -3115,13 +3123,14 @@ *---------------------------------------------------------------------- */ 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)) { if (objPtr->internalRep.wideValue < 0) { wideUIntOutOfRange: @@ -3199,13 +3208,13 @@ *---------------------------------------------------------------------- */ 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)) { *wideIntPtr = objPtr->internalRep.wideValue; return TCL_OK; @@ -3263,13 +3272,13 @@ * *---------------------------------------------------------------------- */ 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); } else { Tcl_WideInt wide; @@ -3575,11 +3584,11 @@ 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); } /* @@ -3610,11 +3619,11 @@ 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); } /* @@ -3635,11 +3644,11 @@ */ 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; Tcl_WideUInt scratch; unsigned char *bytes = (unsigned char *) &scratch; @@ -3927,11 +3936,11 @@ */ #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. */ int line) /* Line number in the source file; used for * debugging. */ @@ -4000,11 +4009,11 @@ */ #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. */ int line) /* Line number in the source file; used for * debugging. */ @@ -4077,21 +4086,20 @@ *---------------------------------------------------------------------- */ 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) { fprintf(stderr, "file = %s, line = %d\n", file, line); fflush(stderr); @@ -4155,11 +4163,12 @@ *---------------------------------------------------------------------- */ 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, &tclObjHashKeyType); } Index: generic/tclParse.c ================================================================== --- generic/tclParse.c +++ generic/tclParse.c @@ -203,11 +203,12 @@ * first null character. */ int nested, /* Non-zero means this is a nested command: * 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. */ { const char *src; /* Points to current character in the * command. */ @@ -1379,22 +1380,27 @@ * underscore: in this case, there is no variable name and the token is * just "$". */ if (*src == '{') { - char ch; int braceCount = 0; + char ch; + int braceCount = 0; src++; numBytes--; tokenPtr->type = TCL_TOKEN_TEXT; tokenPtr->start = src; tokenPtr->numComponents = 0; 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 */ if (numBytes > 1) { src++; numBytes--; @@ -1616,11 +1622,12 @@ const char *start, /* Start of string enclosed in braces. The * first character must be {'. */ 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 * existing tokens in parsePtr and * reinitialize it. */ @@ -1816,11 +1823,12 @@ const char *start, /* Start of the quoted string. The first * character must be '"'. */ 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 * existing tokens in parsePtr and * reinitialize it. */ Index: generic/tclPathObj.c ================================================================== --- generic/tclPathObj.c +++ generic/tclPathObj.c @@ -53,21 +53,21 @@ * * Internal representation of a Tcl_Obj of 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 * is filesystem dependent. */ size_t filesystemEpoch; /* Used to ensure the path representation was @@ -677,14 +677,11 @@ Tcl_IncrRefCount(resultPtr); return resultPtr; } } 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 */ goto standardPath; } else { @@ -2564,15 +2561,15 @@ * TCL_OK - path did not contain leading ~ or it was successful resolved * TCL_ERROR - ~ component could not be resolved. * *---------------------------------------------------------------------- */ -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; assert(path); Index: generic/tclPipe.c ================================================================== --- generic/tclPipe.c +++ generic/tclPipe.c @@ -192,10 +192,11 @@ detPtr->pid = pidPtr[i]; detPtr->nextPtr = detList; detList = detPtr; } Tcl_MutexUnlock(&pipeMutex); + } /* *---------------------------------------------------------------------- * Index: generic/tclPkg.c ================================================================== --- generic/tclPkg.c +++ generic/tclPkg.c @@ -84,16 +84,16 @@ const char *string, char **internal, int *stable); static int CompareVersions(char *v1i, char *v2i, int *isMajorPtr); static int CheckRequirement(Tcl_Interp *interp, const char *string); -static int CheckAllRequirements(Tcl_Interp *interp, Tcl_Size reqc, +static int CheckAllRequirements(Tcl_Interp *interp, int reqc, Tcl_Obj *const reqv[]); static int RequirementSatisfied(char *havei, const char *req); -static int SomeRequirementSatisfied(char *havei, Tcl_Size reqc, +static int SomeRequirementSatisfied(char *havei, int reqc, Tcl_Obj *const reqv[]); -static void AddRequirementsToResult(Tcl_Interp *interp, Tcl_Size reqc, +static void AddRequirementsToResult(Tcl_Interp *interp, int reqc, Tcl_Obj *const reqv[]); static void AddRequirementsToDString(Tcl_DString *dstring, int reqc, Tcl_Obj *const reqv[]); static Package * FindPackage(Tcl_Interp *interp, const char *name); static int PkgRequireCore(void *data[], Tcl_Interp *interp, int result); @@ -581,11 +581,11 @@ void *data[], Tcl_Interp *interp, TCL_UNUSED(int)) { Require *reqPtr = (Require *)data[0]; - Tcl_Size reqc = PTR2INT(data[1]), satisfies; + int reqc = (int)PTR2INT(data[1]), satisfies; Tcl_Obj **const reqv = (Tcl_Obj **)data[2]; char *pkgVersionI; void *clientDataPtr = reqPtr->clientDataPtr; const char *name = reqPtr->name; /* Name of desired package. */ @@ -647,11 +647,11 @@ PkgAvail *availPtr, *bestPtr, *bestStablePtr; char *availVersion, *bestVersion, *bestStableVersion; /* Internal rep. of versions */ int availStable, satisfies; Require *reqPtr = (Require *)data[0]; - Tcl_Size reqc = PTR2INT(data[1]); + int reqc = (int)PTR2INT(data[1]); Tcl_Obj **const reqv = (Tcl_Obj **)data[2]; const char *name = reqPtr->name; Package *pkgPtr = reqPtr->pkgPtr; Interp *iPtr = (Interp *) interp; @@ -1096,17 +1096,16 @@ &optionIndex) != TCL_OK) { return TCL_ERROR; } 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])); if (entry) { @@ -1114,16 +1113,15 @@ } } 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) { Tcl_Obj *obj = (Tcl_Obj *)Tcl_GetHashValue(hPtr); Tcl_DeleteHashEntry(hPtr); @@ -1155,12 +1153,11 @@ } break; } 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?"); return TCL_ERROR; } @@ -1181,17 +1178,18 @@ } argv3 = TclGetStringFromObj(objv[3], &length); 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) { if (objc == 4) { Tcl_Free(argv3i); @@ -1392,22 +1390,21 @@ PkgRequireCore, (void *) argv2, INT2PTR(newobjc), newObjvPtr, NULL); return TCL_OK; } break; - case PKG_UNKNOWN: { - Tcl_Size length; - + case PKG_UNKNOWN: if (objc == 2) { if (iPtr->packageUnknown != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj(iPtr->packageUnknown, -1)); } } else if (objc == 3) { if (iPtr->packageUnknown != NULL) { Tcl_Free(iPtr->packageUnknown); } + Tcl_Size length; argv2 = TclGetStringFromObj(objv[2], &length); if (argv2[0] == 0) { iPtr->packageUnknown = NULL; } else { DupBlock(iPtr->packageUnknown, argv2, length+1); @@ -1415,11 +1412,10 @@ } else { Tcl_WrongNumArgs(interp, 2, objv, "?command?"); return TCL_ERROR; } break; - } case PKG_PREFER: { static const char *const pkgPreferOptions[] = { "latest", "stable", NULL }; @@ -1526,11 +1522,11 @@ Tcl_SetObjResult(interp, Tcl_NewBooleanObj(satisfies)); break; } default: - Tcl_Panic("Tcl_PackageObjCmd: bad option index to pkgOptions"); + TCL_UNREACHABLE(); } return TCL_OK; } static int @@ -1953,14 +1949,14 @@ */ static int CheckAllRequirements( Tcl_Interp *interp, - Tcl_Size reqc, /* Requirements to check. */ + int reqc, /* Requirements to check. */ Tcl_Obj *const reqv[]) { - Tcl_Size i; + int i; for (i = 0; i < reqc; i++) { if ((CheckRequirement(interp, TclGetString(reqv[i])) != TCL_OK)) { return TCL_ERROR; } @@ -2059,11 +2055,11 @@ */ static void AddRequirementsToResult( Tcl_Interp *interp, - Tcl_Size reqc, /* Requirements constraining the desired + int reqc, /* Requirements constraining the desired * version. */ Tcl_Obj *const reqv[]) /* 0 means to use the latest version * available. */ { Tcl_Obj *result = Tcl_GetObjResult(interp); @@ -2139,16 +2135,16 @@ static int SomeRequirementSatisfied( char *availVersionI, /* Candidate version to check against the * requirements. */ - Tcl_Size reqc, /* Requirements constraining the desired + int reqc, /* Requirements constraining the desired * version. */ Tcl_Obj *const reqv[]) /* 0 means to use the latest version * available. */ { - Tcl_Size i; + int i; for (i = 0; i < reqc; i++) { if (RequirementSatisfied(availVersionI, TclGetString(reqv[i]))) { return 1; } Index: generic/tclPlatDecls.h ================================================================== --- generic/tclPlatDecls.h +++ generic/tclPlatDecls.h @@ -46,10 +46,98 @@ # else # define MODULE_SCOPE extern # 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 extern "C" { #endif @@ -102,10 +190,12 @@ (tclPlatStubsPtr->tcl_WinConvertError) /* 3 */ #endif /* defined(USE_TCL_STUBS) */ /* !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) #endif @@ -121,15 +211,18 @@ #ifndef MAC_OSX_TCL # undef Tcl_MacOSXOpenVersionedBundleResources # undef Tcl_MacOSXNotifierAddRunLoopMode #endif +#if defined(USE_TCL_STUBS) && (defined(_WIN32) || defined(__CYGWIN__))\ + && (defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8) #undef Tcl_WinUtfToTChar #undef Tcl_WinTCharToUtf #ifdef _WIN32 #define Tcl_WinUtfToTChar(string, len, dsPtr) (Tcl_DStringInit(dsPtr), \ - (TCHAR *)Tcl_UtfToChar16DString((string), (len), (dsPtr))) + (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 #endif /* _TCLPLATDECLS */ Index: generic/tclProc.c ================================================================== --- generic/tclProc.c +++ generic/tclProc.c @@ -775,12 +775,11 @@ Tcl_Obj *objPtr, /* Object describing frame. */ CallFrame **framePtrPtr) /* Store pointer to frame here (or NULL if * global frame indicated). */ { Interp *iPtr = (Interp *) interp; - int curLevel; - int result, level; + int curLevel, level, result; const Tcl_ObjInternalRep *irPtr; const char *name = NULL; Tcl_WideInt w; /* @@ -1644,11 +1643,11 @@ if (result != TCL_OK) { return TCL_ERROR; } return TclNRInterpProcCore(interp, objv[0], 1, &MakeProcError); } - + static int NRInterpProc( void *clientData, /* Record describing procedure to be * interpreted. */ Tcl_Interp *interp, /* Interpreter in which procedure was @@ -1760,11 +1759,12 @@ TCL_DTRACE_PROC_ARGS(a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], a[8], a[9]); } 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]); TclDecrRefCount(info); } @@ -1873,12 +1873,11 @@ Tcl_SetObjResult(interp, Tcl_ObjPrintf( "invoked \"%s\" outside of a loop", ((result == TCL_BREAK) ? "break" : "continue"))); Tcl_SetErrorCode(interp, "TCL", "RESULT", "UNEXPECTED", (char *)NULL); result = TCL_ERROR; - - /* FALLTHRU */ + TCL_FALLTHROUGH(); case TCL_ERROR: /* * Now it _must_ be an error, so we need to log it as such. This means * filling out the error trace. Luckily, we just hand this off to the Index: generic/tclProcess.c ================================================================== --- generic/tclProcess.c +++ generic/tclProcess.c @@ -497,11 +497,12 @@ } if (Tcl_GetIndexFromObj(interp, objv[1], switches, "switches", 0, &index) != TCL_OK) { return TCL_ERROR; } - ++objv; --objc; + ++objv; + --objc; if (STATUS_WAIT == index) { options = 0; } else { break; } Index: generic/tclResolve.c ================================================================== --- generic/tclResolve.c +++ generic/tclResolve.c @@ -63,11 +63,11 @@ /* Function for variable resolution at compile * time. */ { Interp *iPtr = (Interp *) interp; ResolverScheme *resPtr; - size_t len; + unsigned len; /* * Since we're adding a new name resolution scheme, we must force all code * to be recompiled to use the new scheme. If there are new compiled * variable resolution rules, bump the compiler epoch to invalidate Index: generic/tclScan.c ================================================================== --- generic/tclScan.c +++ generic/tclScan.c @@ -394,15 +394,15 @@ flags |= SCAN_BIG; format += 1; format += TclUtfToUniChar(format, &ch); break; } - /* FALLTHRU */ + TCL_FALLTHROUGH(); case 'j': case 'q': flags |= SCAN_LONGER; - /* FALLTHRU */ + TCL_FALLTHROUGH(); case 'h': format += TclUtfToUniChar(format, &ch); } if (!(flags & SCAN_SUPPRESS) && numVars && (objIndex >= numVars)) { @@ -420,11 +420,11 @@ "field width may not be specified in %c conversion", -1)); Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADWIDTH", (char *)NULL); goto error; } - /* FALLTHRU */ + TCL_FALLTHROUGH(); case 'n': case 's': if (flags & (SCAN_LONGER|SCAN_BIG)) { invalidFieldSize: buf[Tcl_UniCharToUtf(ch, buf)] = '\0'; @@ -434,13 +434,11 @@ Tcl_AppendToObj(errorMsg, " conversion", -1); Tcl_SetObjResult(interp, errorMsg); Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADSIZE", (char *)NULL); goto error; } - /* - * Fall through! - */ + TCL_FALLTHROUGH(); case 'd': case 'e': case 'E': case 'f': case 'g': @@ -747,15 +745,15 @@ flags |= SCAN_BIG; format += 1; format += TclUtfToUniChar(format, &ch); break; } - /* FALLTHRU */ + TCL_FALLTHROUGH(); case 'j': case 'q': flags |= SCAN_LONGER; - /* FALLTHRU */ + TCL_FALLTHROUGH(); case 'h': format += TclUtfToUniChar(format, &ch); } /* Index: generic/tclStrIdxTree.c ================================================================== --- generic/tclStrIdxTree.c +++ generic/tclStrIdxTree.c @@ -522,16 +522,16 @@ Tcl_SetObjResult(interp, Tcl_NewIntObj(ret - cs)); break; 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; } TclStrIdxTreeBuildFromList(&idxTree, lstc, lstv, NULL); @@ -540,10 +540,12 @@ TclStrIdxTreePrint(interp, idxTree.firstPtr, 0); } TclStrIdxTreeFree(idxTree.firstPtr); break; } + default: + TCL_UNREACHABLE(); } return TCL_OK; } #endif Index: generic/tclStrToD.c ================================================================== --- generic/tclStrToD.c +++ generic/tclStrToD.c @@ -38,11 +38,11 @@ /* * 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 * somewhat unpredictably. It is tempting to include fpu_control.h, but that * file exists only on Linux; it is missing on Cygwin and MinGW. Most gcc-isms @@ -670,11 +670,11 @@ } else if (c == '-') { signum = 1; state = SIGNUM; break; } - /* FALLTHROUGH */ + TCL_FALLTHROUGH(); case SIGNUM: /* * Scanned a leading + or -. Acceptable characters are digits, * period, I, and N. @@ -766,11 +766,11 @@ */ acceptState = state; acceptPoint = p; acceptLen = len; - /* FALLTHROUGH */ + TCL_FALLTHROUGH(); case ZERO_O: zeroo: if (c == '0') { numTrailZeros++; state = OCTAL; @@ -845,11 +845,11 @@ case HEXADECIMAL: acceptState = state; acceptPoint = p; acceptLen = len; - /* FALLTHROUGH */ + TCL_FALLTHROUGH(); case ZERO_X: zerox: if (c == '0') { numTrailZeros++; @@ -909,11 +909,11 @@ case BINARY: acceptState = state; acceptPoint = p; acceptLen = len; - /* FALLTHRU */ + TCL_FALLTHROUGH(); case ZERO_B: zerob: if (c == '0') { numTrailZeros++; state = BINARY; @@ -970,11 +970,11 @@ } else if ( ! isdigit(UCHAR(c))) { goto endgame; } state = DECIMAL; flags |= TCL_PARSE_INTEGER_ONLY; - /* FALLTHROUGH */ + TCL_FALLTHROUGH(); case DECIMAL: /* * Scanned an optional + or - followed by a string of decimal * digits. @@ -1022,11 +1022,11 @@ acceptLen = len; if (c == 'E' || c=='e') { state = EXPONENT_START; break; } - /* FALLTHROUGH */ + TCL_FALLTHROUGH(); case LEADING_RADIX_POINT: if (c == '0') { numDigitsAfterDp++; numTrailZeros++; @@ -1064,11 +1064,11 @@ } else if (c == '-') { exponentSignum = 1; state = EXPONENT_SIGNUM; break; } - /* FALLTHROUGH */ + TCL_FALLTHROUGH(); case EXPONENT_SIGNUM: /* * Found the E at the start of the exponent, followed by a sign * character. @@ -1184,11 +1184,11 @@ case sNANHEX: if (c == ')') { state = sNANFINISH; break; } - /* FALLTHROUGH */ + TCL_FALLTHROUGH(); case sNANPAREN: if (TclIsSpaceProcM(c)) { break; } if (numSigDigs < 13) { @@ -1250,11 +1250,11 @@ p++; len--; } } if (endPtrPtr == NULL) { - if ((len != 0) && ((numBytes + 1 > 1) || (*p != '\0'))) { + if ((len != 0) && ((numBytes > 0) || (*p != '\0'))) { status = TCL_ERROR; } } else { *endPtrPtr = p; } @@ -1513,11 +1513,11 @@ objPtr->typePtr = &tclDoubleType; break; #endif case INITIAL: /* This case only to silence compiler warning. */ - Tcl_Panic("TclParseNumber: state INITIAL can't happen here"); + TCL_UNREACHABLE(); } } /* * Format an error message when an invalid number is encountered. @@ -1820,10 +1820,12 @@ int exponent) /* Power of 10 by which to multiply */ { TCL_IEEE_DOUBLE_ROUNDING_DECL int machexp = 0; /* Machine exponent of a power of 10. */ + int shift, n; + mp_int bntmp; /* * With gcc on x86, the floating point rounding mode is double-extended. * This causes the result of double-precision calculations to be rounded * twice: once to the precision of double-extended and then again to the @@ -1866,10 +1868,47 @@ * 1.[string repeat 0 1000]1; while this is a not terribly likely * scenario, we still have to deal with it. Use fraction and exponent * instead. Once we have the significand, multiply by 10**exponent. Test * for overflow. Convert back to a double, and test for underflow. */ + + /* + * TCL bug ca62367d61: the following two if-conditions handle the case, + * if the mantissa is to long to be represented. + * Very high numbers are returned, if this is not handled + */ + + + if (exponent < -511) { + 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; + 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) { + 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; + if (mp_mul_d(&bntmp, (mp_digit) pow10_wide[n], &bntmp) != MP_OKAY) { + Tcl_Panic("initialization failure in MakeHighPrecisionDouble"); + } + shift -= n; + } + significand = &bntmp; + } retval = BignumToBiasedFrExp(significand, &machexp); retval = Pow10TimesFrExp(exponent, retval, &machexp); if (machexp > DBL_MAX_EXP*log2FLT_RADIX) { retval = HUGE_VAL; @@ -1894,10 +1933,13 @@ /* * Come here to return the computed value. */ returnValue: + if (significand == &bntmp) { + mp_clear(&bntmp); + } if (signum) { retval = -retval; } /* @@ -2268,26 +2310,32 @@ { int rv = 0; 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; } @@ -2297,47 +2345,24 @@ * RequiredPrecision -- * * 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. * *---------------------------------------------------------------------- */ static int RequiredPrecision( Tcl_WideUInt w) /* Number to interrogate. */ { - int rv; - unsigned int wi; - - 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; + /* assert(sizeof(Tcl_WideUInt) <= sizeof(long long)) */ + + return w ? 1 + TclMSB((unsigned long long) w) : 0; } /* *---------------------------------------------------------------------- * @@ -3154,11 +3179,13 @@ * Adjust if the logarithm was guessed wrong. */ if (b < S) { b = 10 * b; - ++m2plus; ++m2minus; ++m5; + ++m2plus; + ++m2minus; + ++m5; ilim = ilim1; --k; } /* @@ -3533,11 +3560,13 @@ * Adjust if the logarithm was guessed wrong. */ if ((err == MP_OKAY) && (b.used <= sd)) { err = mp_mul_d(&b, 10, &b); - ++m2plus; ++m2minus; ++m5; + ++m2plus; + ++m2minus; + ++m5; ilim = ilim1; --k; } /* @@ -3573,11 +3602,12 @@ } else { digit = b.dp[sd]; if (b.used > sd+1 || digit >= 10) { Tcl_Panic("wrong digit!"); } - --b.used; mp_clamp(&b); + --b.used; + mp_clamp(&b); } /* * Does the current digit put us on the low side of the exact value * but within roundoff of being exact? @@ -4549,13 +4579,15 @@ /* * Reduce numerator and denominator to lowest terms. */ 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) { /* * If 10*2**s2*5**s5 == 2**(s2+1)+5**(s5+1) fits in a 64-bit word, Index: generic/tclStringObj.c ================================================================== --- generic/tclStringObj.c +++ generic/tclStringObj.c @@ -801,11 +801,11 @@ TclGetRange( Tcl_Obj *objPtr, /* The Tcl object to find the range of. */ 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; if (first < 0) { first = TCL_INDEX_START; @@ -2163,11 +2163,10 @@ allocSegment = 1; break; } case 'u': - /* FALLTHRU */ case 'd': case 'o': case 'p': case 'x': case 'X': @@ -2771,11 +2770,11 @@ } case 'p': if (sizeof(size_t) == sizeof(Tcl_WideInt)) { size = 2; } - /* FALLTHRU */ + TCL_FALLTHROUGH(); case 'c': case 'i': case 'u': case 'd': case 'o': @@ -2866,11 +2865,11 @@ size = 3; p++; break; case 'h': size = -1; - /* FALLTHRU */ + TCL_FALLTHROUGH(); default: p++; } } while (seekingConversion); } @@ -3270,11 +3269,12 @@ } } } 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; /* * Loop until a possibly non-empty value is reached. @@ -3354,11 +3354,12 @@ /* Only one non-empty value or zero length; return first */ /* NOTE: (length == 0) implies (last <= first) */ 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) { /* Efficiently produce a pure byte array result */ unsigned char *dst; @@ -3369,11 +3370,12 @@ */ 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 { objResultPtr = Tcl_NewByteArrayObj(NULL, length); dst = Tcl_SetByteArrayLength(objResultPtr, length); @@ -3399,11 +3401,12 @@ Tcl_UniChar *dst; if (inPlace) { Tcl_Size start; - objResultPtr = *objv++; objc--; + objResultPtr = *objv++; + objc--; /* Ugly interface! Force resize of the unicode array. */ (void)Tcl_GetUnicodeFromObj(objResultPtr, &start); Tcl_InvalidateStringRep(objResultPtr); if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) { @@ -3450,11 +3453,12 @@ char *dst; if (inPlace) { Tcl_Size start; - objResultPtr = *objv++; objc--; + objResultPtr = *objv++; + objc--; (void)TclGetStringFromObj(objResultPtr, &start); if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) { if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -4362,53 +4366,10 @@ *dst++ = unichar; } } *dst = 0; } - -/* - *---------------------------------------------------------------------- - * - * Tcl_IsEmpty -- - * - * Check whether the obj is the empty string. - * - * Results: - * 1 if the obj is "" - * 0 otherwise - * - * Side effects: - * If there is no other way to determine whethere the string - * representation is the empty string, the string representation - * is generated. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_IsEmpty( - Tcl_Obj *objPtr) -{ - if (objPtr == NULL) { - Tcl_Panic("%s: objPtr is NULL", "Tcl_IsEmpty"); - } - if (!objPtr->bytes) { - if (TclHasInternalRep(objPtr, &tclDictType)) { - /* Since "dict" doesn't have a lengthProc */ - Tcl_Size size; - Tcl_DictObjSize(NULL, objPtr, &size); - return !size; - } - - Tcl_ObjTypeLengthProc *proc = TclObjTypeHasProc(objPtr, lengthProc); - if (proc != NULL) { - return !proc(objPtr); - } - (void)TclGetString(objPtr); - } - return !objPtr->length; -} /* *---------------------------------------------------------------------- * * DupStringInternalRep -- Index: generic/tclStringRep.h ================================================================== --- generic/tclStringRep.h +++ generic/tclStringRep.h @@ -64,11 +64,11 @@ ((String *) (objPtr)->internalRep.twoPtrValue.ptr1) #define SET_STRING(objPtr, stringPtr) \ ((objPtr)->internalRep.twoPtrValue.ptr2 = NULL), \ ((objPtr)->internalRep.twoPtrValue.ptr1 = (void *) (stringPtr)) -#endif /* _TCLSTRINGREP */ +#endif /* _TCLSTRINGREP */ /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 Index: generic/tclStubInit.c ================================================================== --- generic/tclStubInit.c +++ generic/tclStubInit.c @@ -204,10 +204,21 @@ *objcPtr = (int)n; } return result; } #endif /* !defined(TCL_NO_DEPRECATED) */ + +#define Tcl_CreateHashEntry createHashEntry +static Tcl_HashEntry * +Tcl_CreateHashEntry( + Tcl_HashTable *tablePtr, + const void *key, + int *newPtr) +{ + return (*((tablePtr)->createProc))(tablePtr, (const char *)(key), newPtr); +} + #define TclBN_mp_add mp_add #define TclBN_mp_add_d mp_add_d #define TclBN_mp_and mp_and #define TclBN_mp_clamp mp_clamp @@ -671,11 +682,11 @@ TclPtrSetVar, /* 253 */ TclPtrIncrObjVar, /* 254 */ TclPtrObjMakeUpvar, /* 255 */ TclPtrUnsetVar, /* 256 */ TclStaticLibrary, /* 257 */ - 0, /* 258 */ + TclMSB, /* 258 */ 0, /* 259 */ 0, /* 260 */ TclUnusedStubEntry, /* 261 */ }; @@ -848,13 +859,13 @@ 0, /* 26 */ Tcl_DbNewObj, /* 27 */ Tcl_DbNewStringObj, /* 28 */ Tcl_DuplicateObj, /* 29 */ TclFreeObj, /* 30 */ - 0, /* 31 */ - 0, /* 32 */ - 0, /* 33 */ + Tcl_GetBoolean, /* 31 */ + Tcl_GetBooleanFromObj, /* 32 */ + Tcl_GetByteArrayFromObj, /* 33 */ Tcl_GetDouble, /* 34 */ Tcl_GetDoubleFromObj, /* 35 */ 0, /* 36 */ Tcl_GetInt, /* 37 */ Tcl_GetIntFromObj, /* 38 */ @@ -898,11 +909,11 @@ 0, /* 76 */ 0, /* 77 */ Tcl_BadChannelOption, /* 78 */ Tcl_CallWhenDeleted, /* 79 */ Tcl_CancelIdleCall, /* 80 */ - 0, /* 81 */ + Tcl_Close, /* 81 */ Tcl_CommandComplete, /* 82 */ Tcl_Concat, /* 83 */ Tcl_ConvertElement, /* 84 */ Tcl_ConvertCountedElement, /* 85 */ Tcl_CreateAlias, /* 86 */ @@ -1239,11 +1250,11 @@ Tcl_ClearChannelHandlers, /* 417 */ Tcl_IsChannelExisting, /* 418 */ 0, /* 419 */ 0, /* 420 */ 0, /* 421 */ - 0, /* 422 */ + Tcl_CreateHashEntry, /* 422 */ Tcl_InitCustomHashTable, /* 423 */ Tcl_InitObjHashTable, /* 424 */ Tcl_CommandTraceInfo, /* 425 */ Tcl_TraceCommand, /* 426 */ Tcl_UntraceCommand, /* 427 */ @@ -1507,10 +1518,9 @@ Tcl_DStringToObj, /* 685 */ Tcl_UtfNcmp, /* 686 */ Tcl_UtfNcasecmp, /* 687 */ Tcl_NewWideUIntObj, /* 688 */ Tcl_SetWideUIntObj, /* 689 */ - Tcl_IsEmpty, /* 690 */ - TclUnusedStubEntry, /* 691 */ + TclUnusedStubEntry, /* 690 */ }; /* !END!: Do not edit above this line. */ Index: generic/tclTest.c ================================================================== --- generic/tclTest.c +++ generic/tclTest.c @@ -249,10 +249,11 @@ static Tcl_ObjCmdProc TestlinkCmd; 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; static Tcl_ObjCmdProc TestparseargsCmd; static Tcl_ObjCmdProc TestparserCmd; @@ -645,10 +646,11 @@ Tcl_CreateObjCommand(interp, "testlink", TestlinkCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testlinkarray", TestlinkarrayCmd, NULL, NULL); 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, NULL, NULL); Tcl_CreateObjCommand(interp, "testparsevar", TestparsevarCmd, @@ -827,13 +829,13 @@ */ 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; static int nextId = 1; @@ -943,11 +945,11 @@ return TCL_OK; } static int AsyncHandlerProc( - void *clientData, /* If of TestAsyncHandler structure. + void *clientData, /* If of TestAsyncHandler structure. * in global list. */ Tcl_Interp *interp, /* Interpreter in which command was * executed, or NULL. */ int code) /* Current return code from command. */ { @@ -1005,11 +1007,11 @@ *---------------------------------------------------------------------- */ static Tcl_ThreadCreateType AsyncThreadProc( - void *clientData) /* Parameter is the id of a + void *clientData) /* Parameter is the id of a * TestAsyncHandler, defined above. */ { TestAsyncHandler *asyncPtr; int id = PTR2INT(clientData); @@ -1062,11 +1064,11 @@ 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; resultObj = Tcl_NewListObj(0, NULL); Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewWideIntObj(objc)); @@ -1099,11 +1101,11 @@ static int 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 }; enum options { @@ -1212,11 +1214,11 @@ return TCL_OK; } 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*/) { TestCommandTokenRef *refPtr = (TestCommandTokenRef *) clientData; @@ -1224,11 +1226,11 @@ return TCL_OK; } 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*/) { Tcl_AppendResult(interp, "CmdProc1 ", (char *)clientData, (char *)NULL); @@ -1235,11 +1237,11 @@ return TCL_OK; } 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*/) { Tcl_AppendResult(interp, "CmdProc2 ", (char *)clientData, (char *)NULL); @@ -1246,11 +1248,11 @@ return TCL_OK; } static void CmdDelProc0( - void *clientData) /* String to save. */ + void *clientData) /* String to save. */ { TestCommandTokenRef *thisRefPtr, *prevRefPtr = NULL; TestCommandTokenRef *refPtr = (TestCommandTokenRef *) clientData; int id = refPtr->id; for (thisRefPtr = firstCommandTokenRef; refPtr != NULL; @@ -1268,20 +1270,20 @@ Tcl_Free(refPtr); } static void CmdDelProc1( - void *clientData) /* String to save. */ + void *clientData) /* String to save. */ { Tcl_DStringInit(&delString); Tcl_DStringAppend(&delString, "CmdDelProc1 ", -1); Tcl_DStringAppend(&delString, (char *)clientData, -1); } static void CmdDelProc2( - void *clientData) /* String to save. */ + void *clientData) /* String to save. */ { Tcl_DStringInit(&delString); Tcl_DStringAppend(&delString, "CmdDelProc2 ", -1); Tcl_DStringAppend(&delString, (char *)clientData, -1); } @@ -1475,16 +1477,16 @@ return TCL_OK; } 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. */ Tcl_Obj *const *objv) /* Arguments. */ { @@ -1581,11 +1583,11 @@ static int 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"); return TCL_ERROR; } @@ -1700,11 +1702,11 @@ * The deletion callback used by 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); char buffer[TCL_INTEGER_SPACE]; @@ -1762,11 +1764,11 @@ return TCL_OK; } 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*/) { DelCmd *dPtr = (DelCmd *) clientData; @@ -1777,11 +1779,11 @@ return TCL_OK; } static void DelDeleteProc( - void *clientData) /* String command to evaluate. */ + void *clientData) /* String command to evaluate. */ { DelCmd *dPtr = (DelCmd *)clientData; Tcl_EvalEx(dPtr->interp, dPtr->deleteCmd, TCL_INDEX_NONE, 0); Tcl_ResetResult(dPtr->interp); @@ -2037,12 +2039,16 @@ * The procedure below is used as a special freeProc to test how well * Tcl_DStringGetResult handles freeProc's other than free. */ static void SpecialFree( - void *blockPtr) /* Block to free. */ -{ +#if TCL_MAJOR_VERSION > 8 + void *blockPtr /* Block to free. */ +#else + char *blockPtr /* Block to free. */ +#endif +) { Tcl_Free(((char *)blockPtr) - 16); } /* *------------------------------------------------------------------------ @@ -2176,14 +2182,15 @@ } if (flags & TCL_ENCODING_CHAR_LIMIT) { /* 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) { return TCL_ERROR; } @@ -2369,11 +2376,11 @@ return TCL_OK; } static int EncodingToUtfProc( - void *clientData, /* TclEncoding structure. */ + void *clientData, /* TclEncoding structure. */ TCL_UNUSED(const char *) /*src*/, int srcLen, /* Source string length in bytes. */ TCL_UNUSED(int) /*flags*/, TCL_UNUSED(Tcl_EncodingState *), char *dst, /* Output buffer. */ @@ -2401,11 +2408,11 @@ return TCL_OK; } 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*/, TCL_UNUSED(Tcl_EncodingState *), char *dst, /* Output buffer. */ @@ -2433,11 +2440,11 @@ return TCL_OK; } static void EncodingFreeProc( - void *clientData) /* ClientData associated with type. */ + void *clientData) /* ClientData associated with type. */ { TclEncoding *encodingPtr = (TclEncoding *)clientData; Tcl_Free(encodingPtr->toUtfCmd); Tcl_Free(encodingPtr->fromUtfCmd); @@ -2692,11 +2699,11 @@ */ 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 */ const char *evNameStr; Tcl_Obj *targetName; /* Name of the event(s) to delete */ @@ -2765,11 +2772,11 @@ return TCL_OK; } static void ExitProcOdd( - void *clientData) /* Integer value to print. */ + void *clientData) /* Integer value to print. */ { char buf[16 + TCL_INTEGER_SPACE]; int len; snprintf(buf, sizeof(buf), "odd %d\n", (int)PTR2INT(clientData)); @@ -2779,11 +2786,11 @@ } } static void ExitProcEven( - void *clientData) /* Integer value to print. */ + void *clientData) /* Integer value to print. */ { char buf[16 + TCL_INTEGER_SPACE]; int len; snprintf(buf, sizeof(buf), "even %d\n", (int)PTR2INT(clientData)); @@ -2982,11 +2989,11 @@ static int 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"); return TCL_ERROR; } @@ -3654,13 +3661,13 @@ */ 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 }; enum LinkOptionEnum { LINK_UPDATE, LINK_REMOVE, LINK_CREATE } optionIndex; @@ -3773,13 +3780,13 @@ */ 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[] = { "new", "describe", @@ -3987,15 +3994,57 @@ *---------------------------------------------------------------------- */ static void CleanupTestSetassocdataTests( - void *clientData, /* Data to be released. */ + void *clientData, /* Data to be released. */ TCL_UNUSED(Tcl_Interp *)) { Tcl_Free(clientData); } + +/* + *---------------------------------------------------------------------- + * + * 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 -- @@ -4628,12 +4677,12 @@ *---------------------------------------------------------------------- */ 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 */ { size_t i; int cflags, eflags; @@ -5791,12 +5840,12 @@ *---------------------------------------------------------------------- */ static int TestsetCmd( - void *data, /* Additional flags for Get/SetVar2. */ - Tcl_Interp *interp, /* Current interpreter. */ + void *data, /* Additional flags for Get/SetVar2. */ + Tcl_Interp *interp,/* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* Arguments. */ { int flags = PTR2INT(data); const char *value; @@ -5822,12 +5871,12 @@ return TCL_ERROR; } } static int Testset2Cmd( - void *data, /* Additional flags for Get/SetVar2. */ - Tcl_Interp *interp, /* Current interpreter. */ + void *data, /* Additional flags for Get/SetVar2. */ + Tcl_Interp *interp,/* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* Argument strings. */ { int flags = PTR2INT(data); const char *value; @@ -5872,11 +5921,11 @@ */ 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) { if (objc == 1) { Tcl_Obj *idObj = Tcl_NewWideIntObj((Tcl_WideInt)(size_t)Tcl_GetCurrentThread()); @@ -6001,11 +6050,11 @@ Tcl_HashSearch hSearch; /* Search variable. */ Tcl_HashEntry *hPtr; /* Search variable. */ 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 */ if (objc < 2) { @@ -6701,11 +6750,11 @@ Tcl_Interp *interp, /* Interpreter for result. */ int objc, /* Count of additional args. */ 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..?"); return TCL_ERROR; } @@ -6816,11 +6865,11 @@ 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; const char *msg; @@ -7597,11 +7646,12 @@ static int 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 ; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "STRING INDEX"); @@ -8339,13 +8389,15 @@ * B) the caller's namespace is "ctx1" or "ctx2" */ 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) * * - The context, in which this resolver becomes active, is * determined by the name of the caller proc, which has to be @@ -8423,11 +8475,11 @@ return TCL_CONTINUE; } 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; static inline void @@ -8585,15 +8637,14 @@ * In the presence of the apply bug, may panic. Otherwise * Interpreter result holds result or error message. * *------------------------------------------------------------------------ */ -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]; Tcl_Obj *evalObjs[2]; Tcl_Obj *lambdaObj; @@ -8712,11 +8763,11 @@ /* Avoid the loop below if lengths differ */ if (nL1 != nL2) { Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); break; } - /* FALLTHRU */ + TCL_FALLTHROUGH(); case LUTIL_DIFFINDEX: nCmp = nL1 <= nL2 ? nL1 : nL2; for (i = 0; i < nCmp; ++i) { if (strcmp(Tcl_GetString(l1Elems[i]), Tcl_GetString(l2Elems[i]))) { break; Index: generic/tclTestABSList.c ================================================================== --- generic/tclTestABSList.c +++ generic/tclTestABSList.c @@ -48,15 +48,15 @@ /* * Internal Representation of an lstring type value */ 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; /* * AbstractList definition of an lstring type */ @@ -603,21 +603,21 @@ if (newStr != oldStr) { strncpy(newStr, oldStr, first); } // move front elements to keep - for (x=0, kx=0; xstrlen && xstrlen && xinternalRep.twoPtrValue.ptr1; for (i=0, bytlen=0; ilen; i++) { @@ -1060,12 +1060,13 @@ } Tcl_AppendObjToObj(tmpstr,element); } } - 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; } Index: generic/tclTestObj.c ================================================================== --- generic/tclTestObj.c +++ generic/tclTestObj.c @@ -44,11 +44,10 @@ static Tcl_ObjCmdProc TestintobjCmd; 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 static void @@ -132,12 +131,10 @@ Tcl_CreateObjCommand(interp, "testlistobj", TestlistobjCmd, NULL, NULL); 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); } return TCL_OK; @@ -591,11 +588,11 @@ /* * Keep this structure declaration in sync with tclIndexObj.c */ 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; if ((objc == 3) && (strcmp(Tcl_GetString(objv[1]), "check") == 0)) { @@ -919,12 +916,12 @@ LISTOBJ_GETELEMENTSMEMCHECK, LISTOBJ_INDEX, } 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; if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg...?"); @@ -1080,17 +1077,17 @@ return TCL_OK; } 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 }; static int @@ -1491,11 +1488,11 @@ } else { length = TCL_INDEX_NONE; } Tcl_SetWideIntObj(Tcl_GetObjResult(interp), length); break; - case 10: { /* range */ + case 10: { /* range */ Tcl_Size first, last; if (objc != 5) { goto wrongNumArgs; } if ((Tcl_GetIntForIndex(interp, objv[3], TCL_INDEX_NONE, &first) != TCL_OK) @@ -1565,11 +1562,11 @@ } 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; if (Tcl_GetIntFromObj(interp, objv[i + 3], &val) != TCL_OK) { break; @@ -1611,13 +1608,13 @@ *------------------------------------------------------------------------ */ 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 }; enum options { @@ -1829,36 +1826,12 @@ return 1; } return 0; } -static int -TestisemptyCmd ( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - Tcl_Obj *result; - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "value"); - return TCL_ERROR; - } - result = Tcl_NewIntObj(Tcl_IsEmpty(objv[1])); - if (!objv[1]->bytes) { - Tcl_AppendToObj(result, " pure", TCL_INDEX_NONE); - } - if (objv[1]->typePtr) { - Tcl_AppendToObj(result, " ", TCL_INDEX_NONE); - Tcl_AppendToObj(result, objv[1]->typePtr->name, TCL_INDEX_NONE); - } - Tcl_SetObjResult(interp, result); - return TCL_OK; -} - /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ Index: generic/tclTestProcBodyObj.c ================================================================== --- generic/tclTestProcBodyObj.c +++ generic/tclTestProcBodyObj.c @@ -36,11 +36,11 @@ * this struct describes an entry in the table of command names and command * procs */ 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; /* Index: generic/tclThread.c ================================================================== --- generic/tclThread.c +++ generic/tclThread.c @@ -21,13 +21,13 @@ * These statics are guarded by the mutex in the caller of * TclRememberThreadData, e.g., TclpThreadDataKeyInit */ 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}; static SyncObjRecord mutexRecord = {0, 0, NULL}; static SyncObjRecord condRecord = {0, 0, NULL}; @@ -107,10 +107,11 @@ */ void * TclThreadDataKeyGet( Tcl_ThreadDataKey *keyPtr) /* Identifier for the data chunk. */ + { #if TCL_THREADS return TclThreadStorageKeyGet(keyPtr); #else /* TCL_THREADS */ return *keyPtr; Index: generic/tclThreadAlloc.c ================================================================== --- generic/tclThreadAlloc.c +++ generic/tclThreadAlloc.c @@ -90,11 +90,11 @@ /* All fields below for accounting only */ 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; /* * The following structure defines a cache of buckets and objs, of which there * will be (at most) one per thread. Any changes need to be reflected in the Index: generic/tclThreadStorage.c ================================================================== --- generic/tclThreadStorage.c +++ generic/tclThreadStorage.c @@ -46,11 +46,11 @@ /* * The type of the data held per thread in a system TSD. */ 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; /* Index: generic/tclThreadTest.c ================================================================== --- generic/tclThreadTest.c +++ generic/tclThreadTest.c @@ -99,10 +99,11 @@ Tcl_ThreadId srcThreadId; /* Id of sending thread, in case it dies */ Tcl_ThreadId dstThreadId; /* Id of target thread, in case it dies */ struct ThreadEvent *eventPtr; /* Back pointer */ struct ThreadEventResult *nextPtr; /* List for cleanup */ struct ThreadEventResult *prevPtr; + } ThreadEventResult; static ThreadEventResult *resultList; /* Index: generic/tclTimer.c ================================================================== --- generic/tclTimer.c +++ generic/tclTimer.c @@ -19,11 +19,11 @@ */ 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 * queue. */ } TimerHandler; @@ -71,11 +71,11 @@ * linked together into a list. */ 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. */ } IdleHandler; @@ -249,11 +249,11 @@ Tcl_TimerToken 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; /* * Compute when the event should fire. @@ -617,11 +617,11 @@ */ 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; ThreadSpecificData *tsdPtr = InitTimer(); @@ -661,11 +661,11 @@ */ 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; ThreadSpecificData *tsdPtr = InitTimer(); @@ -977,11 +977,11 @@ (afterPtr->token == NULL) ? "idle" : "timer", -1)); Tcl_SetObjResult(interp, resultListPtr); } break; default: - Tcl_Panic("Tcl_AfterObjCmd: bad subcommand index to afterSubCmds"); + TCL_UNREACHABLE(); } return TCL_OK; } /* @@ -1113,11 +1113,11 @@ cmdString = TclGetString(commandPtr); if (strncmp(cmdString, "after#", 6) != 0) { return NULL; } cmdString += 6; - id = (int)strtoul(cmdString, &end, 10); + id = strtoul(cmdString, &end, 10); if ((end == cmdString) || (*end != 0)) { return NULL; } for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL; afterPtr = afterPtr->nextPtr) { @@ -1147,11 +1147,11 @@ *---------------------------------------------------------------------- */ static void AfterProc( - void *clientData) /* Describes command to execute. */ + void *clientData) /* Describes command to execute. */ { AfterInfo *afterPtr = (AfterInfo *)clientData; AfterAssocData *assocPtr = afterPtr->assocPtr; AfterInfo *prevPtr; int result; @@ -1212,11 +1212,11 @@ *---------------------------------------------------------------------- */ static void FreeAfterPtr( - AfterInfo *afterPtr) /* Command to be deleted. */ + AfterInfo *afterPtr) /* Command to be deleted. */ { AfterInfo *prevPtr; AfterAssocData *assocPtr = afterPtr->assocPtr; if (assocPtr->firstAfterPtr == afterPtr) { @@ -1249,11 +1249,11 @@ *---------------------------------------------------------------------- */ static void AfterCleanupProc( - void *clientData, /* Points to AfterAssocData for the + void *clientData, /* Points to AfterAssocData for the * interpreter. */ TCL_UNUSED(Tcl_Interp *)) { AfterAssocData *assocPtr = (AfterAssocData *)clientData; AfterInfo *afterPtr; Index: generic/tclTrace.c ================================================================== --- generic/tclTrace.c +++ generic/tclTrace.c @@ -20,11 +20,11 @@ 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 * byte. */ } TraceVarInfo; @@ -42,11 +42,11 @@ int flags; /* Operations for which Tcl command is to be * invoked. */ 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 * traces, store the command name which * invoked step trace */ @@ -54,11 +54,11 @@ int curCode; /* Return code for the current command */ size_t refCount; /* Used to ensure this structure is not * 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 * byte. */ } TraceCommandInfo; @@ -144,11 +144,11 @@ * The following structure holds the client data for string-based * trace procs */ 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; /* * Convenience macros for iterating over the list of traces. Note that each of @@ -248,13 +248,13 @@ if (Tcl_GetIndexFromObj(interp, objv[2], traceTypeOptions, "option", 0, &typeIndex) != TCL_OK) { return TCL_ERROR; } return traceSubCmds[typeIndex](interp, optionIndex, objc, objv); - break; } - + default: + TCL_UNREACHABLE(); } return TCL_OK; } /* @@ -277,12 +277,12 @@ */ 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; Tcl_Size length; static const char *const opStrings[] = { @@ -342,10 +342,12 @@ flags |= TCL_TRACE_ENTER_DURING_EXEC; break; case TRACE_EXEC_LEAVE_STEP: flags |= TCL_TRACE_LEAVE_DURING_EXEC; break; + default: + TCL_UNREACHABLE(); } } command = TclGetStringFromObj(objv[5], &length); if (optionIndex == TRACE_ADD) { TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)Tcl_Alloc( @@ -498,10 +500,12 @@ Tcl_ListObjAppendElement(interp, resultListPtr, eachTraceObjPtr); } Tcl_SetObjResult(interp, resultListPtr); break; } + default: + TCL_UNREACHABLE(); } return TCL_OK; } /* @@ -524,12 +528,12 @@ */ 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; Tcl_Size length; static const char *const opStrings[] = { "delete", "rename", NULL }; @@ -578,10 +582,12 @@ flags |= TCL_TRACE_RENAME; break; case TRACE_CMD_DELETE: flags |= TCL_TRACE_DELETE; break; + default: + TCL_UNREACHABLE(); } } command = TclGetStringFromObj(objv[5], &length); if (optionIndex == TRACE_ADD) { @@ -692,10 +698,12 @@ Tcl_ListObjAppendElement(interp, resultListPtr, eachTraceObjPtr); } Tcl_SetObjResult(interp, resultListPtr); break; } + default: + TCL_UNREACHABLE(); } return TCL_OK; } /* @@ -718,12 +726,12 @@ */ 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; Tcl_Size length; void *clientData; @@ -783,10 +791,12 @@ flags |= TCL_TRACE_UNSETS; break; case TRACE_VAR_WRITE: flags |= TCL_TRACE_WRITES; break; + default: + TCL_UNREACHABLE(); } } command = TclGetStringFromObj(objv[5], &length); if (optionIndex == TRACE_ADD) { CombinedTraceVarInfo *ctvarPtr = (CombinedTraceVarInfo *)Tcl_Alloc( @@ -876,10 +886,12 @@ eachTraceObjPtr); } Tcl_SetObjResult(interp, resultListPtr); break; } + default: + TCL_UNREACHABLE(); } return TCL_OK; } /* @@ -979,11 +991,11 @@ int flags, /* OR-ed collection of bits, including any of * TCL_TRACE_RENAME, TCL_TRACE_DELETE, and any * 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; cmdPtr = (Command *) Tcl_FindCommand(interp, cmdName, NULL, @@ -1042,11 +1054,11 @@ const char *cmdName, /* Name of command. */ int flags, /* OR-ed collection of bits, including any of * 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; Command *cmdPtr; Interp *iPtr = (Interp *)interp; @@ -1147,11 +1159,11 @@ *---------------------------------------------------------------------- */ 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 * means command is being deleted (renamed to * ""). */ @@ -1292,11 +1304,11 @@ * string. */ TCL_UNUSED(Tcl_Size) /*numChars*/, 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; CommandTrace *tracePtr, *lastTracePtr; ActiveCommandTrace active; @@ -1398,11 +1410,11 @@ Tcl_Size numChars, /* The number of characters in 'command' which * are part of the command string. */ 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; Trace *tracePtr, *lastTracePtr; ActiveInterpTrace active; @@ -1536,11 +1548,11 @@ */ 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. */ Tcl_Size numChars, /* The number of characters in the command's * source. */ @@ -1785,11 +1797,11 @@ */ if ((flags & TCL_TRACE_ENTER_EXEC) && (tcmdPtr->stepTrace == NULL) && (tcmdPtr->flags & (TCL_TRACE_ENTER_DURING_EXEC | TCL_TRACE_LEAVE_DURING_EXEC))) { - size_t len = strlen(command) + 1; + unsigned len = strlen(command) + 1; tcmdPtr->startLevel = level; tcmdPtr->startCmd = (char *)Tcl_Alloc(len); memcpy(tcmdPtr->startCmd, command, len); tcmdPtr->refCount++; @@ -1831,11 +1843,11 @@ *---------------------------------------------------------------------- */ 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 * scalar variable is being referenced. */ int flags) /* OR-ed bits giving operation and other @@ -2014,14 +2026,14 @@ } 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 */ { TraceWrapperInfo *info = (TraceWrapperInfo *)Tcl_Alloc(sizeof(TraceWrapperInfo)); info->proc = proc; @@ -2033,14 +2045,14 @@ } 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 */ { Trace *tracePtr; Interp *iPtr = (Interp *) interp; @@ -2122,15 +2134,15 @@ */ 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)); data->clientData = clientData; data->proc = proc; @@ -2774,11 +2786,11 @@ int flags, /* OR-ed collection of bits describing current * trace, including any of TCL_TRACE_READS, * TCL_TRACE_WRITES, TCL_TRACE_UNSETS, * TCL_GLOBAL_ONLY, and TCL_NAMESPACE_ONLY. */ Tcl_VarTraceProc *proc, /* Function associated with trace. */ - void *clientData) /* Arbitrary argument to pass to proc. */ + void *clientData) /* Arbitrary argument to pass to proc. */ { VarTrace *tracePtr; VarTrace *prevPtr, *nextPtr; Var *varPtr, *arrayPtr; Interp *iPtr = (Interp *) interp; @@ -2977,11 +2989,11 @@ * TCL_TRACE_READS, TCL_TRACE_WRITES, * TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY, and * TCL_NAMESPACE_ONLY. */ Tcl_VarTraceProc *proc, /* Function to call when specified ops are * invoked upon varName. */ - void *clientData) /* Arbitrary argument to pass to proc. */ + void *clientData) /* Arbitrary argument to pass to proc. */ { VarTrace *tracePtr; int result; tracePtr = (VarTrace *)Tcl_Alloc(sizeof(VarTrace)); Index: generic/tclUtf.c ================================================================== --- generic/tclUtf.c +++ generic/tclUtf.c @@ -550,11 +550,11 @@ */ if (((byte & 0xC0) == 0x80) && ((src[1] & 0xC0) == 0x80) && ((src[2] & 0xC0) == 0x80) && (((((byte - 0x10) << 2) & 0xFC) | 0xD800) == (*chPtr & 0xFCFC)) && ((src[1] & 0xF0) == (((*chPtr << 4) & 0x30) | 0x80))) { - *chPtr = (unsigned short)(((src[1] & 0x0F) << 6) + (src[2] & 0x3F) + 0xDC00); + *chPtr = ((src[1] & 0x0F) << 6) + (src[2] & 0x3F) + 0xDC00; return 3; } if ((unsigned)(byte-0x80) < (unsigned)0x20) { *chPtr = cp1252[byte-0x80]; } else { @@ -602,11 +602,11 @@ */ Tcl_UniChar high = (((byte & 0x07) << 8) | ((src[1] & 0x3F) << 2) | ((src[2] & 0x3F) >> 4)) - 0x40; if (high < 0x400) { /* produce high surrogate, advance source pointer */ - *chPtr = (unsigned short)(0xD800 + high); + *chPtr = 0xD800 + high; return 1; } /* out of range, < 0x10000 or > 0x10FFFF */ } @@ -799,13 +799,13 @@ *--------------------------------------------------------------------------- */ 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; if (length < 0) { @@ -851,13 +851,13 @@ return i; } 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; if (length < 0) { @@ -1175,12 +1175,12 @@ *--------------------------------------------------------------------------- */ 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; if (index < 0) { @@ -1211,12 +1211,12 @@ *--------------------------------------------------------------------------- */ 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; while (index-- > 0) { src += TclUtfToUniChar(src, &ch); @@ -1224,12 +1224,12 @@ return src; } 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; if (index > 0) { @@ -1644,12 +1644,12 @@ return ch1; } } else if ((ch2 & 0xFC00) == 0xD800) { return -ch2; } - ch1 = (unsigned short)Tcl_UniCharToLower(ch1); - ch2 = (unsigned short)Tcl_UniCharToLower(ch2); + ch1 = Tcl_UniCharToLower(ch1); + ch2 = Tcl_UniCharToLower(ch2); if (ch1 != ch2) { return (ch1 - ch2); } } } Index: generic/tclUtil.c ================================================================== --- generic/tclUtil.c +++ generic/tclUtil.c @@ -17,10 +17,15 @@ #include "tclParse.h" #include "tclStringTrim.h" #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. */ @@ -1096,100 +1101,101 @@ preferBrace = 1; #endif /* COMPAT */ } while (length) { - if (CHAR_TYPE(*p) != TYPE_NORMAL) { - switch (*p) { - case '{': /* TYPE_BRACE */ -#if COMPAT - braceCount++; -#endif /* COMPAT */ - extra++; /* Escape '{' => '\{' */ - nestingLevel++; - break; - case '}': /* TYPE_BRACE */ -#if COMPAT - braceCount++; -#endif /* COMPAT */ - extra++; /* Escape '}' => '\}' */ - if (nestingLevel-- < 1) { - /* - * Unbalanced braces! Cannot format with brace quoting. - */ - - requireEscape = 1; - } - break; - case ']': /* TYPE_CLOSE_BRACK */ - case '"': /* TYPE_SPACE */ -#if COMPAT - forbidNone = 1; - extra++; /* Escapes all just prepend a backslash */ - preferEscape = 1; - break; -#else - /* FLOW THROUGH */ -#endif /* COMPAT */ - case '[': /* TYPE_SUBS */ - case '$': /* TYPE_SUBS */ - case ';': /* TYPE_COMMAND_END */ - forbidNone = 1; - extra++; /* Escape sequences all one byte longer. */ -#if COMPAT - 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 */ - - /* - * 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)) { - forbidNone = 1; - extra++; /* Escape sequences all one byte longer. */ -#if COMPAT - preferBrace = 1; -#endif - } - break; - } - } + if (CHAR_TYPE(*p) != TYPE_NORMAL) { + switch (*p) { + case '{': /* TYPE_BRACE */ +#if COMPAT + braceCount++; +#endif /* COMPAT */ + extra++; /* Escape '{' => '\{' */ + nestingLevel++; + break; + case '}': /* TYPE_BRACE */ +#if COMPAT + braceCount++; +#endif /* COMPAT */ + extra++; /* Escape '}' => '\}' */ + if (nestingLevel-- < 1) { + /* + * Unbalanced braces! Cannot format with brace quoting. + */ + + requireEscape = 1; + } + break; + case ']': /* TYPE_CLOSE_BRACK */ + case '"': /* TYPE_SPACE */ +#if COMPAT + forbidNone = 1; + extra++; /* Escapes all just prepend a backslash */ + preferEscape = 1; + break; +#else + TCL_FALLTHROUGH(); +#endif /* COMPAT */ + case '[': /* TYPE_SUBS */ + case '$': /* TYPE_SUBS */ + case ';': /* TYPE_COMMAND_END */ + forbidNone = 1; + extra++; /* Escape sequences all one byte longer. */ +#if COMPAT + 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 */ + + /* + * 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)) { + forbidNone = 1; + extra++; /* Escape sequences all one byte longer. */ +#if COMPAT + preferBrace = 1; +#endif + } + break; + } + } length -= (length > 0); p++; } endOfString: @@ -1625,11 +1631,13 @@ */ 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++; } dst[-1] = 0; @@ -2119,12 +2127,12 @@ const char *str, /* String. */ const char *pattern, /* Pattern, which may contain special * 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; /* @@ -2625,12 +2633,12 @@ length = strlen(bytes); } 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; if (newSize > dsPtr->spaceAvl) { @@ -2768,11 +2776,11 @@ if (dsPtr->string == dsPtr->staticSpace) { char *newString = (char *) TclAllocEx(newSize, &dsPtr->spaceAvl); memcpy(newString, dsPtr->string, dsPtr->length); dsPtr->string = newString; } else { - int offset = -1; + Tcl_Size offset = -1; /* See [16896d49fd] */ if (element >= dsPtr->string && element <= dsPtr->string + dsPtr->length) { /* Source string is within this DString. Note offset */ @@ -4441,11 +4449,11 @@ for (p = reStr + 4; p < strEnd; p++) { switch (*p) { case '\\': case '*': case '[': case ']': case '?': /* Only add \ where necessary for glob */ *dsStr++ = '\\'; - /* fall through */ + TCL_FALLTHROUGH(); default: *dsStr++ = *p; break; } } @@ -4522,11 +4530,11 @@ break; case '*': case '[': case ']': case '?': /* 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; break; default: @@ -4608,12 +4616,182 @@ } Tcl_DStringFree(dsPtr); return TCL_ERROR; } +/* + *---------------------------------------------------------------------- + * + * 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) + 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 * fill-column: 78 * End: */ Index: generic/tclVar.c ================================================================== --- generic/tclVar.c +++ generic/tclVar.c @@ -3915,10 +3915,12 @@ if (matched < 0) { TclDecrRefCount(resultObj); return TCL_ERROR; } break; + default: + TCL_UNREACHABLE(); } if (matched == 0) { continue; } } @@ -6946,14 +6948,14 @@ return NotArrayError(interp, arrayNameObj); } SetArrayDefault(varPtr, NULL); } return TCL_OK; - } - /* Unreached */ - return TCL_ERROR; + default: + TCL_UNREACHABLE(); + } } /* * Initialize array variable. */ Index: generic/tclZipfs.c ================================================================== --- generic/tclZipfs.c +++ generic/tclZipfs.c @@ -3881,11 +3881,12 @@ SerializeCentralDirectorySuffix( const unsigned char *start, /* The start of writable memory. */ 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 * central directory. */ long long suffixStartOffset)/* The overall file offset of the start of the @@ -4254,10 +4255,12 @@ regexp = Tcl_RegExpCompile(interp, TclGetString(objv[2])); if (!regexp) { return TCL_ERROR; } break; + default: + TCL_UNREACHABLE(); } } else if (objc == 2) { pattern = TclGetString(objv[1]); } @@ -5631,11 +5634,11 @@ Tcl_Size prefixLen, len, strip = 0; char *pat, *prefix, *path; Tcl_DString dsPref, *prefixBuf = NULL; int foundInHash, notDuplicate; ZipEntry *z; - int wanted; /* TCL_GLOB_TYPE* */ + int wanted; /* TCL_GLOB_TYPE* */ if (!normPathPtr) { return -1; } if (types) { Index: generic/tclZlib.c ================================================================== --- generic/tclZlib.c +++ generic/tclZlib.c @@ -393,13 +393,11 @@ * Catch-all. Should be unreachable because all cases are already * listed above. */ default: - TclNewLiteralStringObj(objv[2], "UNKNOWN"); - TclNewIntObj(objv[3], code); - return Tcl_NewListObj(4, objv); + TCL_UNREACHABLE(); } } /* *---------------------------------------------------------------------- @@ -2103,23 +2101,25 @@ if (Tcl_GetIndexFromObj(interp, objv[i], gzipopts, "option", 0, &option) != TCL_OK) { 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; } if (level < 0 || level > 9) { extraInfoStr = "\n (in -level option)"; goto badLevel; } break; + default: + TCL_UNREACHABLE(); } } return Tcl_ZlibDeflate(interp, TCL_ZLIB_FORMAT_GZIP, objv[2], level, headerDictObj); case CMD_INFLATE: /* inflate rawcomprdata ?bufferSize? @@ -2177,11 +2177,11 @@ if (Tcl_GetIndexFromObj(interp, objv[i], gunzipopts, "option", 0, &option) != TCL_OK) { return TCL_ERROR; } switch (option) { - case 0: + case 0: // -buffersize if (TclGetWideIntFromObj(interp, objv[i + 1], &wideLen) != TCL_OK) { return TCL_ERROR; } if (wideLen < MIN_NONSTREAM_BUFFER_SIZE @@ -2188,14 +2188,16 @@ || wideLen > MAX_BUFFER_SIZE) { goto badBuffer; } 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], buffersize, headerDictObj) != TCL_OK) { if (headerDictObj) { @@ -2213,14 +2215,15 @@ * -> handleCmd */ return ZlibStreamSubcmd(interp, objc, objv); case CMD_PUSH: /* push mode channel options... * -> channel */ return ZlibPushSubcmd(interp, objc, objv); + + default: // Should be no other options + TCL_UNREACHABLE(); } - return TCL_ERROR; - badLevel: Tcl_SetObjResult(interp, Tcl_NewStringObj( "level must be 0 to 9", TCL_AUTO_LENGTH)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMPRESSIONLEVEL", (char *)NULL); if (extraInfoStr) { @@ -2338,11 +2341,11 @@ desc = gunzipOpts; mode = TCL_ZLIB_STREAM_INFLATE; format = TCL_ZLIB_FORMAT_GZIP; break; default: - Tcl_Panic("should be unreachable"); + TCL_UNREACHABLE(); } /* * Parse the options. */ @@ -2470,11 +2473,11 @@ case FMT_GUNZIP: mode = TCL_ZLIB_STREAM_INFLATE; format = TCL_ZLIB_FORMAT_GZIP; break; default: - Tcl_Panic("should be unreachable"); + TCL_UNREACHABLE(); } if (TclGetChannelFromObj(interp, objv[3], &chan, &chanMode, 0) != TCL_OK) { return TCL_ERROR; } @@ -2553,10 +2556,12 @@ Tcl_SetErrorCode(interp, "TCL", "ZIP", "BADOPT", (char *)NULL); goto genericOptionError; } compDictObj = objv[i]; break; + default: + TCL_UNREACHABLE(); } } if (compDictObj && (NULL == Tcl_GetBytesFromObj(interp, compDictObj, (Tcl_Size *)NULL))) { @@ -2706,13 +2711,13 @@ if (objc != 2) { Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } return Tcl_ZlibStreamReset(zstream); + default: + TCL_UNREACHABLE(); } - - return TCL_OK; } static int ZlibStreamAddCmd( void *clientData, @@ -2785,10 +2790,12 @@ Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", (char *)NULL); return TCL_ERROR; } compDictObj = objv[++i]; break; + default: + TCL_UNREACHABLE(); } if (flush == -2) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "\"-flush\", \"-fullflush\" and \"-finalize\" options" @@ -2893,10 +2900,12 @@ Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", (char *)NULL); return TCL_ERROR; } compDictObj = objv[++i]; break; + default: + TCL_UNREACHABLE(); } if (flush == -2) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "\"-flush\", \"-fullflush\" and \"-finalize\" options" " are mutually exclusive", TCL_AUTO_LENGTH)); Index: library/dde/pkgIndex.tcl ================================================================== --- library/dde/pkgIndex.tcl +++ library/dde/pkgIndex.tcl @@ -1,5 +1,12 @@ -if {![package vsatisfies [package provide Tcl] 9.0-]} return if {[info sharedlibextension] != ".dll"} return -package ifneeded dde 1.5a0 \ - [list load [file join $dir tcl9dde15.dll] Dde] - +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] +} Index: library/init.tcl ================================================================== --- library/init.tcl +++ library/init.tcl @@ -13,11 +13,11 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -package require -exact tcl 9.1a0 +package require -exact tcl 9.0.2 # Compute the auto path to use in this interpreter. # The values on the path come from several locations: # # The environment variable TCLLIBPATH @@ -589,13 +589,13 @@ return $auto_execs($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)" ";"] } else { set execExtensions [list {} .com .exe .bat .cmd] Index: library/registry/pkgIndex.tcl ================================================================== --- library/registry/pkgIndex.tcl +++ library/registry/pkgIndex.tcl @@ -1,4 +1,9 @@ -if {![package vsatisfies [package provide Tcl] 9.0-]} return +if {![package vsatisfies [package provide Tcl] 8.5-]} return if {[info sharedlibextension] != ".dll"} return -package ifneeded registry 1.4a0 \ - [list load [file join $dir tcl9registry14.dll] Registry] +if {[package vsatisfies [package provide Tcl] 9.0-]} { + package ifneeded registry 1.3.7 \ + [list load [file join $dir tcl9registry13.dll] Registry] +} else { + package ifneeded registry 1.3.7 \ + [list load [file join $dir tclregistry13.dll] Registry] +} Index: macosx/README ================================================================== --- macosx/README +++ macosx/README @@ -90,13 +90,13 @@ ---------------------------------------------------------- - 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.1'). +(where ${ver} is a shell variable containing the Tcl version number e.g. '9.0'). Setup this shell variable as follows: - ver="9.1" + ver="9.0" - 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" export CFLAGS Index: macosx/tclMacOSXFCmd.c ================================================================== --- macosx/tclMacOSXFCmd.c +++ macosx/tclMacOSXFCmd.c @@ -68,15 +68,15 @@ static Tcl_Obj * NewOSTypeObj(const OSType newOSType); 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 }; enum { kIsInvisible = 0x4000, @@ -116,14 +116,14 @@ *---------------------------------------------------------------------- */ 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; Tcl_StatBuf statBuf; struct attrlist alist; @@ -685,11 +685,11 @@ OSType osType = (OSType) objPtr->internalRep.wideValue; int written = 0; Tcl_Encoding encoding; char src[5]; - TclOOM(dst, size); + TclOOM(dst, size+1); src[0] = (char) (osType >> 24); src[1] = (char) (osType >> 16); src[2] = (char) (osType >> 8); src[3] = (char) (osType); Index: macosx/tclMacOSXNotify.c ================================================================== --- macosx/tclMacOSXNotify.c +++ macosx/tclMacOSXNotify.c @@ -159,11 +159,11 @@ int readyMask; /* Mask of events that have been seen since * the last time file handlers were invoked * 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; /* * The following structure is what is added to the Tcl event queue when file @@ -294,11 +294,11 @@ * * You must hold the notifierLock lock before writing to the pipe. */ 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. * * You must hold the notifierInitLock before accessing this variable. @@ -820,11 +820,11 @@ *---------------------------------------------------------------------- */ void TclpSetTimer( - const Tcl_Time *timePtr) /* Timeout value, may be NULL. */ + const Tcl_Time *timePtr) /* Timeout value, may be NULL. */ { ThreadSpecificData *tsdPtr; CFRunLoopTimerRef runLoopTimer; CFTimeInterval waitTime; @@ -934,11 +934,11 @@ * TCL_WRITABLE, and TCL_EXCEPTION: indicates * conditions under which proc should be * 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); if (filePtr == NULL) { @@ -1181,11 +1181,11 @@ *---------------------------------------------------------------------- */ 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; SInt32 runLoopStatus; ThreadSpecificData *tsdPtr; Index: tests/async.test ================================================================== --- tests/async.test +++ tests/async.test @@ -19,11 +19,11 @@ ::tcltest::loadTestedCommands 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 set aresult $result set acode $code ADDED tests/brodnik.test Index: tests/brodnik.test ================================================================== --- /dev/null +++ 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 Index: tests/clock.test ================================================================== --- tests/clock.test +++ tests/clock.test @@ -35528,11 +35528,11 @@ 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] \ [clock format 86400 -format %x -gmt 1 -locale en_US_roman_xx_yy] } {01/02/1970 02.01.1970 1970|01|02} # END testcases29 Index: tests/cmdAH.test ================================================================== --- tests/cmdAH.test +++ tests/cmdAH.test @@ -321,11 +321,11 @@ test cmdAH-4.1.1 {encoding} -returnCodes error -body { encoding } -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.* badnumargs cmdAH-4.2.1 {encoding system} {ascii ascii} test cmdAH-4.2.2 {Tcl_EncodingObjCmd} -setup { @@ -1266,11 +1266,11 @@ } -returnCodes error -result {could not read "~_bad_user": no such file or directory} 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 -body {file readable a b} -result {wrong # args: should be "file readable name"} @@ -1309,11 +1309,11 @@ # executable 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"} test cmdAH-18.2 {Tcl_FileObjCmd: executable} {notRoot notWsl} { file executable $gorpfile @@ -1354,16 +1354,16 @@ test cmdAH-19.1 {Tcl_FileObjCmd: exists} -returnCodes error -body { file exists a b } -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 } 1 test cmdAH-19.5 {Tcl_FileObjCmd: exists} { @@ -1420,11 +1420,11 @@ # Stat related commands 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 if {[testConstraint unix] && [file exists /tmp]} { set file [makeFile "data" touch.me /tmp] @@ -1840,11 +1840,11 @@ set res } -result 0 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 test cmdAH-28.1 {Tcl_FileObjCmd: stat} -returnCodes error -body { file stat Index: tests/encoding.test ================================================================== --- tests/encoding.test +++ tests/encoding.test @@ -10,11 +10,11 @@ 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 catch { @@ -1055,11 +1055,11 @@ } -result {wrong # args: should be "encoding dirs ?dirList?"} 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 { set string hello foreach name [encoding names] { @@ -1148,10 +1148,36 @@ perf } -body { 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 test encoding-bug-6a3e2cb0f0-2 {Bug [6a3e2cb0f0] - invalid bytes in escape encodings} -body { encoding convertfrom -profile strict iso2022-jp x\x1B\x7Aaby @@ -1191,14 +1217,33 @@ } -result ? 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 return # Local Variables: # mode: tcl # End: Index: tests/exec.test ================================================================== --- tests/exec.test +++ tests/exec.test @@ -27,11 +27,11 @@ # according to MS, winget can only be used on servers with an installed desktop interface, # no idea how to check it in GHA programmatically, so simply disable it (todo: rewrite with better check later) 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 # Utilities that are like Bourne shell stalwarts, but cross-platform. @@ -46,10 +46,15 @@ set path(echo2) [makeFile { puts stdout [join $argv] 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 - } fconfigure stdout -translation binary @@ -566,11 +571,11 @@ test exec-14.2 {-keepnewline switch} -constraints {exec} -body { exec -keepnewline } -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} test exec-14.5 {-ignorestderr switch} {exec} { # Alas, the use of -ignorestderr is buried here :-( @@ -748,10 +753,19 @@ encoding system $enc } -body { 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 foreach cmdBuiltin { @@ -759,15 +773,15 @@ 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 { - 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 # ---------------------------------------------------------------------- # cleanup Index: tests/fileName.test ================================================================== --- tests/fileName.test +++ tests/fileName.test @@ -1441,11 +1441,11 @@ } //[info hostname]/c/globTest 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} test filename-16.15 {windows specific globbing} {win} { cd [lindex [glob -types d -dir C:/ *] 0] Index: tests/format.test ================================================================== --- tests/format.test +++ tests/format.test @@ -18,11 +18,11 @@ # %z/%t/%p output depends on pointerSize, so some tests are not portable. 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 } { 34 16923 -12 -1} test format-1.2 {integer formatting} { Index: tests/icu.test ================================================================== --- tests/icu.test +++ tests/icu.test @@ -5,13 +5,18 @@ if {"::tcltest" ni [namespace children]} { package require tcltest 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} test icu-detect-0 {Return list of ICU encodings} -constraints icu -body { Index: tests/io.test ================================================================== --- tests/io.test +++ tests/io.test @@ -10016,11 +10016,11 @@ } -body { set f [open [list | [info nameofexecutable] << { 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 }]] 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 ""] Index: tests/lseq.test ================================================================== --- tests/lseq.test +++ tests/lseq.test @@ -24,10 +24,11 @@ set fd [open /proc/[pid]/statm] set line [gets $fd] if {[llength $line] != 7} { error "Unexpected /proc/pid/statm format" } + close $fd return [lindex $line 5] } testConstraint hasMemUsage [expr {![catch {memusage}]}] # Arg errors @@ -1029,11 +1030,11 @@ set l [lseq 1000000] proc p l {foreach x $l {}} 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 { set bl [expr {2.8 in [lseq 0 count 100 by .1]}] lappend bl [expr {2.8 in [lseq 0 count 200 by .1]}] @@ -1062,14 +1063,64 @@ lappend result [lseq 3.0] lappend result [lseq 5.1e1] lappend result [string compare [lseq 3] [lseq 3.0]] 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 {{} {}} + +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 {{} {}} + +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 {bad index "foo": must be integer?[+-]integer? or end?[+-]integer?} -returnCodes error + +test lseq-bug-452b103a74-0 {Bug 452b103a74 - crash on nested indices} -body { + lindex [lseq 10] 0 1 +} -result {} + +test lseq-bug-452b103a74-1 {Bug 452b103a74 - crash on nested indices} -body { + lindex [lseq 10] 0 end +} -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 + +test lseq-bug-0ee626dfb2-0 {Bug 0ee626dfb2 - integer overflow} -body { + lseq 0x7fffffffffffffff count 2 +} -result {invalid arithmetic series parameter values} -returnCodes error + +test lseq-bug-0ee626dfb2-1 {Bug 0ee626dfb2 - integer overflow} -body { + lseq 0x7fffffffffffffff count 3 by -0x8000000000000000 +} -result {invalid arithmetic series parameter values} -returnCodes error # cleanup ::tcltest::cleanupTests return # Local Variables: # mode: tcl # End: Index: tests/registry.test ================================================================== --- tests/registry.test +++ tests/registry.test @@ -17,11 +17,11 @@ testConstraint reg 0 if {[testConstraint win]} { if {![catch { ::tcltest::loadTestedCommands - set ::regver [package require registry 1.4a0] + set ::regver [package require registry 1.3.7] }]} { testConstraint reg 1 } } testConstraint notWine [expr {![info exists ::env(CI_USING_WINE)]}] @@ -32,11 +32,11 @@ && [string match "English*" [testlocale all ""]] }] test registry-1.0 {check if we are testing the right dll} {win reg} { set ::regver -} {1.4a0} +} {1.3.7} test registry-1.1 {argument parsing for registry command} {win reg} { list [catch {registry} msg] $msg } {1 {wrong # args: should be "registry ?-32bit|-64bit? option ?arg ...?"}} test registry-1.1a {argument parsing for registry command} {win reg} { list [catch {registry -32bit} msg] $msg Index: tests/scan.test ================================================================== --- tests/scan.test +++ tests/scan.test @@ -877,10 +877,56 @@ } Inf test scan-14.2 {negative infinity} { scan -Inf %g d return $d } -Inf + +test scan-15.1 {scan %g overflow for small numbers and big mantissa bug 42d14c495a} { + set result [list] + # xfail: n = not expected at all, x expected when unfixed + foreach {exp numdig ret xfail} { + -321 190 1.1116477031428047e-321 n0 + -321 191 1.1116477031428047e-321 x1 + -321 300 1.1116477031428047e-321 x2 + -321 1600 1.1116477031428047e-321 x3 + -400 110 0 n4 + -400 111 0 n5 + -400 300 0 n6 + -221 290 1.111111111111111e-221 n7 + -221 291 1.111111111111111e-221 x8 + -221 400 1.111111111111111e-221 x9 + -221 1600 1.111111111111111e-221 x10 + -121 390 1.1111111111111112e-121 n11 + -121 391 1.1111111111111112e-121 x12 + -121 500 1.1111111111111112e-121 x13 + -121 1600 1.1111111111111112e-121 x14 + 308 202 1.1111111111111112e+308 n15 + 308 203 1.1111111111111112e+308 n16 + 308 300 1.1111111111111112e+308 n17 + 308 1600 1.1111111111111112e+308 x18 + 400 110 *inf n19 + 400 111 *inf n20 + 400 300 *inf n21 + 221 291 1.1111111111111112e+221 n22 + 221 292 1.1111111111111112e+221 n23 + 221 400 1.1111111111111112e+221 n24 + 221 1600 1.1111111111111112e+221 x25 + 121 391 1.1111111111111111e+121 n26 + 121 392 1.1111111111111111e+121 n27 + 121 500 1.1111111111111111e+121 n28 + 121 1600 1.1111111111111111e+121 x29 + } { + set s 1.[string repeat 1 $numdig]e$exp + set d "no_scan" + scan $s %g d + set r [format %.17g $d] + if {![string match -nocase $ret $r]} { + lappend result $xfail=[format %.17g $d] + } + } + set result +} {} # TODO - also need to scan NaN's catch {rename int_range {}} Index: tests/stringObj.test ================================================================== --- tests/stringObj.test +++ tests/stringObj.test @@ -19,11 +19,10 @@ ::tcltest::loadTestedCommands catch [list package require -exact tcl::test [info patchlevel]] testConstraint testobj [llength [info commands testobj]] -testConstraint testisempty [llength [info commands testisempty]] testConstraint testbytestring [llength [info commands testbytestring]] testConstraint testdstring [llength [info commands testdstring]] test stringObj-1.1 {string type registration} testobj { set t [testobj types] @@ -526,30 +525,10 @@ test stringObj-16.12 {Tcl_GetRange: first = last = SIZE_MAX-1} testobj { teststringobj set 1 abcde set i [expr {$SIZE_MAX - 1}] teststringobj range 1 $i $i } {} - -test stringObj-17.1 {Tcl_StringIsEmpty, handle list} testisempty { - set x "abc" - lappend x "def" - testisempty $x -} {0 pure list} -test stringObj-17.2 {Tcl_StringIsEmpty, handle empty list} testisempty { - set x "abc" - set x [lreplace x 0 end] - list $x {*}[testisempty $x] -} {{} 1 pure list} -test stringObj-17.3 {Tcl_StringIsEmpty, handle dict} testisempty { - set x "1 abc" - set x [dict set $x 2 "def"] - testisempty $x -} {0 pure dict} -test stringObj-17.4 {Tcl_StringIsEmpty, handle integer} testisempty { - testisempty [expr {3+4}] -} {0 pure int} - if {[testConstraint testobj]} { testobj freeallvars } Index: tests/tcltests.tcl ================================================================== --- tests/tcltests.tcl +++ tests/tcltests.tcl @@ -114,10 +114,29 @@ "$label extra arguments" \ -body "$cmd $arguments" \ -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 package provide tcltests 0.1 Index: tests/utfext.test ================================================================== --- tests/utfext.test +++ tests/utfext.test @@ -183,20 +183,30 @@ set in [binary decode hex $hexin] set infrag [string range $in 0 $fragindex-1] 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] lassign $frag2Result frag2Status frag2State frag2Decoded set decoded [string cat [string range $frag1Decoded 0 $frag1Written-1] [string range $frag2Decoded 0 $frag2Written-1]] list $frag1Status [expr {$frag1Read <= $fragindex}] \ $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} { set id $comment-[join $hexin ""]-charlimit @@ -318,10 +328,52 @@ } -body { set src \x82\x4F\x82\x50\x82 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 ::tcltest::cleanupTests Index: tests/winDde.test ================================================================== --- tests/winDde.test +++ tests/winDde.test @@ -17,11 +17,11 @@ testConstraint dde 0 if {[testConstraint win]} { if {![catch { ::tcltest::loadTestedCommands - set ::ddever [package require dde 1.5] + set ::ddever [package require dde 1.4.5] set ::ddelib [info loaded {} Dde]}]} { testConstraint dde 1 } } testConstraint notWine [expr {![info exists ::env(CI_USING_WINE)]}] @@ -103,11 +103,11 @@ } # ------------------------------------------------------------------------- test winDde-1.0 {check if we are testing the right dll} {win dde} { set ::ddever -} {1.5a0} +} {1.4.5} test winDde-1.1 {Settings the server's topic name} -constraints dde -body { list [dde servername foobar] [dde servername] [dde servername self] } -result {foobar foobar self} Index: tests/winFCmd.test ================================================================== --- tests/winFCmd.test +++ tests/winFCmd.test @@ -27,11 +27,11 @@ testConstraint exdev 0 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] puts -nonewline $f $string close $f Index: unix/Makefile.in ================================================================== --- unix/Makefile.in +++ unix/Makefile.in @@ -2030,17 +2030,26 @@ # If PKG_DIR is changed to a different relative depth to the build dir, need # to adapt the ../.. relative paths below and at the top of configure.ac (we # 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 \ if [ -d $$i ] ; then \ 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; \ $$i/configure --with-tcl=../.. \ --with-tclinclude=$(GENERIC_DIR) \ @@ -2053,10 +2062,14 @@ 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 $$?; \ fi; \ fi; \ @@ -2064,10 +2077,15 @@ 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 \ "DESTDIR=$(INSTALL_ROOT)"; ) || exit $$?; \ fi; \ @@ -2091,10 +2109,13 @@ 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; \ fi; \ done @@ -2101,16 +2122,21 @@ 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 @rm -rf $(DISTROOT)/pkgs; \ mkdir -p $(DISTROOT)/pkgs; \ @@ -2276,14 +2302,15 @@ DIST_INSTALL_SCRIPT = $(INSTALL) -p -m 755 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. Please upgrade autoconf." -$(UNIX_DIR)/tclConfig.h.in: $(MAC_OSX_DIR)/configure.ac - @cd $(MAC_OSX_DIR); autoheader || touch $@ + cd $(UNIX_DIR); autoconf +$(MAC_OSX_DIR)/configure: $(MAC_OSX_DIR)/configure.ac $(UNIX_DIR)/configure + cd $(MAC_OSX_DIR); autoconf +$(UNIX_DIR)/tclConfig.h.in: $(MAC_OSX_DIR)/configure + cd $(MAC_OSX_DIR); autoheader; touch $@ tclUuid.h: $(TOP_DIR)/manifest.uuid echo "#define TCL_VERSION_UUID \\" >$@ cat $(TOP_DIR)/manifest.uuid >>$@ echo "" >>$@ @@ -2294,11 +2321,11 @@ (printf "svn-r" >$(TOP_DIR)/manifest.uuid ; \ svn info --show-item last-changed-revision >>$(TOP_DIR)/manifest.uuid) || \ printf "unknown" >$(TOP_DIR)/manifest.uuid) dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in genstubs \ - $(TOP_DIR)/manifest.uuid dist-packages ${NATIVE_TCLSH} + $(MAC_OSX_DIR)/configure $(TOP_DIR)/manifest.uuid dist-packages ${NATIVE_TCLSH} rm -rf $(DISTDIR) $(INSTALL_DATA_DIR) $(DISTDIR)/unix $(DIST_INSTALL_DATA) $(TOP_DIR)/manifest.uuid $(DISTDIR) $(DIST_INSTALL_DATA) $(UNIX_DIR)/*.c $(UNIX_DIR)/tclUnixPort.h $(DISTDIR)/unix $(DIST_INSTALL_DATA) $(UNIX_DIR)/Makefile.in $(DISTDIR)/unix @@ -2400,10 +2427,11 @@ $(INSTALL_DATA_DIR) $(DISTDIR)/macosx $(DIST_INSTALL_DATA) $(MAC_OSX_DIR)/GNUmakefile $(MAC_OSX_DIR)/README \ $(MAC_OSX_DIR)/*.c $(MAC_OSX_DIR)/*.in \ $(MAC_OSX_DIR)/*.ac \ $(DISTDIR)/macosx + $(DIST_INSTALL_SCRIPT) $(MAC_OSX_DIR)/configure $(DISTDIR)/macosx $(DIST_INSTALL_DATA) $(TOP_DIR)/license.terms $(DISTDIR)/macosx $(INSTALL_DATA_DIR) $(DISTDIR)/unix/dltest $(DIST_INSTALL_DATA) $(UNIX_DIR)/dltest/*.c $(UNIX_DIR)/dltest/Makefile.in \ $(UNIX_DIR)/dltest/README $(DISTDIR)/unix/dltest $(INSTALL_DATA_DIR) $(DISTDIR)/tools Index: unix/configure ================================================================== --- unix/configure +++ unix/configure @@ -1,8 +1,8 @@ #! /bin/sh # Guess values for system-dependent variables and create Makefiles. -# Generated by GNU Autoconf 2.72 for tcl 9.1. +# Generated by GNU Autoconf 2.72 for tcl 9.0. # # # Copyright (C) 1992-1996, 1998-2017, 2020-2023 Free Software Foundation, # Inc. # @@ -599,12 +599,12 @@ MAKEFLAGS= # Identity of this package. PACKAGE_NAME='tcl' PACKAGE_TARNAME='tcl' -PACKAGE_VERSION='9.1' -PACKAGE_STRING='tcl 9.1' +PACKAGE_VERSION='9.0' +PACKAGE_STRING='tcl 9.0' PACKAGE_BUGREPORT='' PACKAGE_URL='' # Factoring default headers for most tests. ac_includes_default="\ @@ -1364,11 +1364,11 @@ # 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.1 to adapt to many kinds of systems. +'configure' configures tcl 9.0 to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... To assign environment variables (e.g., CC, CFLAGS...), specify them as VAR=VALUE. See below for descriptions of some of the useful variables. @@ -1426,11 +1426,11 @@ _ACEOF fi if test -n "$ac_init_help"; then case $ac_init_help in - short | recursive ) echo "Configuration of tcl 9.1:";; + short | recursive ) echo "Configuration of tcl 9.0:";; esac cat <<\_ACEOF Optional Features: --disable-option-checking ignore unrecognized --enable/--with options @@ -1543,11 +1543,11 @@ fi test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then cat <<\_ACEOF -tcl configure 9.1 +tcl configure 9.0 generated by GNU Autoconf 2.72 Copyright (C) 2023 Free Software Foundation, Inc. This configure script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it. @@ -2026,11 +2026,11 @@ 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.1, which was +It was created by tcl $as_me 9.0, which was generated by GNU Autoconf 2.72. Invocation command line was $ $0$ac_configure_args_raw _ACEOF @@ -2705,14 +2705,14 @@ -TCL_VERSION=9.1 +TCL_VERSION=9.0 TCL_MAJOR_VERSION=9 -TCL_MINOR_VERSION=1 -TCL_PATCH_LEVEL="a0" +TCL_MINOR_VERSION=0 +TCL_PATCH_LEVEL=".2" VERSION=${TCL_VERSION} EXTRA_INSTALL_BINARIES=${EXTRA_INSTALL_BINARIES:-"@:"} EXTRA_BUILD_HTML=${EXTRA_BUILD_HTML:-"@:"} @@ -11300,12 +11300,10 @@ #-------------------------------------------------------------------- if test "$FRAMEWORK_BUILD" = "1" ; then test -z "$TCL_PACKAGE_PATH" && \ TCL_PACKAGE_PATH="~/Library/Tcl:/Library/Tcl:~/Library/Frameworks:/Library/Frameworks" - # Allow tclsh to find Tk when multiple versions are installed. See Tk [1562e10c58]. - TCL_PACKAGE_PATH="$TCL_PACKAGE_PATH:/Library/Frameworks/Tk.framework/Versions" test -z "$TCL_MODULE_PATH" && \ TCL_MODULE_PATH="~/Library/Tcl /Library/Tcl" elif test "$prefix/lib" != "$libdir"; then test -z "$TCL_PACKAGE_PATH" && TCL_PACKAGE_PATH="${libdir}:${prefix}/lib" else @@ -11922,11 +11920,11 @@ cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # Save the log message, to keep $0 and so on meaningful, and to # 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.1, which was +This file was extended by tcl $as_me 9.0, which was generated by GNU Autoconf 2.72. Invocation command line was CONFIG_FILES = $CONFIG_FILES CONFIG_HEADERS = $CONFIG_HEADERS CONFIG_LINKS = $CONFIG_LINKS @@ -11981,11 +11979,11 @@ ac_cs_config=`printf "%s\n" "$ac_configure_args" | sed "$ac_safe_unquote"` ac_cs_config_escaped=`printf "%s\n" "$ac_cs_config" | sed "s/^ //; s/'/'\\\\\\\\''/g"` cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_config='$ac_cs_config_escaped' ac_cs_version="\\ -tcl config.status 9.1 +tcl config.status 9.0 configured by $0, generated by GNU Autoconf 2.72, with options \\"\$ac_cs_config\\" Copyright (C) 2023 Free Software Foundation, Inc. This config.status script is free software; the Free Software Foundation Index: unix/configure.ac ================================================================== --- unix/configure.ac +++ unix/configure.ac @@ -1,12 +1,12 @@ #! /bin/bash -norc 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.1]) -AC_PREREQ([2.72]) +AC_INIT([tcl],[9.0]) +AC_PREREQ([2.69]) dnl This is only used when included from macosx/configure.ac m4_ifdef([SC_USE_CONFIG_HEADERS], [ AC_CONFIG_HEADERS([tclConfig.h:../unix/tclConfig.h.in]) AC_CONFIG_COMMANDS_PRE([DEFS="-DHAVE_TCL_CONFIG_H -imacros tclConfig.h"]) @@ -21,14 +21,14 @@ /* override */ #undef PACKAGE_VERSION /* override */ #undef PACKAGE_STRING #endif /* _TCLCONFIG */]) ]) -TCL_VERSION=9.1 +TCL_VERSION=9.0 TCL_MAJOR_VERSION=9 -TCL_MINOR_VERSION=1 -TCL_PATCH_LEVEL="a0" +TCL_MINOR_VERSION=0 +TCL_PATCH_LEVEL=".2" VERSION=${TCL_VERSION} EXTRA_INSTALL_BINARIES=${EXTRA_INSTALL_BINARIES:-"@:"} EXTRA_BUILD_HTML=${EXTRA_BUILD_HTML:-"@:"} @@ -866,12 +866,10 @@ #-------------------------------------------------------------------- if test "$FRAMEWORK_BUILD" = "1" ; then test -z "$TCL_PACKAGE_PATH" && \ TCL_PACKAGE_PATH="~/Library/Tcl:/Library/Tcl:~/Library/Frameworks:/Library/Frameworks" - # Allow tclsh to find Tk when multiple versions are installed. See Tk [1562e10c58]. - TCL_PACKAGE_PATH="$TCL_PACKAGE_PATH:/Library/Frameworks/Tk.framework/Versions" test -z "$TCL_MODULE_PATH" && \ TCL_MODULE_PATH="~/Library/Tcl /Library/Tcl" elif test "$prefix/lib" != "$libdir"; then test -z "$TCL_PACKAGE_PATH" && TCL_PACKAGE_PATH="${libdir}:${prefix}/lib" else Index: unix/dltest/Makefile.in ================================================================== --- unix/dltest/Makefile.in +++ unix/dltest/Makefile.in @@ -25,17 +25,17 @@ CC_SWITCHES = $(CFLAGS) -I${SRC_DIR}/../../generic \ ${SHLIB_CFLAGS} -DUSE_TCL_STUBS ${AC_FLAGS} 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} + tcl9pkgooa${SHLIB_SUFFIX} pkga${SHLIB_SUFFIX} pkgb${SHLIB_SUFFIX} pkgc${SHLIB_SUFFIX} pkgt${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} + tcl9pkgooa${DLTEST_SUFFIX} pkga${DLTEST_SUFFIX} pkgb${DLTEST_SUFFIX} pkgc${DLTEST_SUFFIX} pkgt${DLTEST_SUFFIX} @touch ../dltest.marker embtest.o: $(SRC_DIR)/embtest.c $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/embtest.c @@ -52,10 +52,22 @@ $(CC) -c $(CC_SWITCHES) $(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 pkge.o: $(SRC_DIR)/pkge.c $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkge.c @@ -82,10 +94,22 @@ ${SHLIB_LD} -o $@ pkgc.o ${SHLIB_LD_LIBS} 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} tcl9pkge${SHLIB_SUFFIX}: pkge.o ${SHLIB_LD} -o $@ pkge.o ${SHLIB_LD_LIBS} @@ -109,10 +133,22 @@ ${DLTEST_LD} -o $@ pkgc.o ${SHLIB_LD_LIBS} 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} tcl9pkge${DLTEST_SUFFIX}: pkge.o ${DLTEST_LD} -o $@ pkge.o ${SHLIB_LD_LIBS} Index: unix/tcl.m4 ================================================================== --- unix/tcl.m4 +++ unix/tcl.m4 @@ -91,15 +91,15 @@ `ls -d ${exec_prefix}/lib 2>/dev/null` \ `ls -d ${prefix}/lib 2>/dev/null` \ `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.1 2>/dev/null` \ + `ls -d /usr/lib/tcl9.0 2>/dev/null` \ `ls -d /usr/lib 2>/dev/null` \ `ls -d /usr/lib64 2>/dev/null` \ - `ls -d /usr/local/lib/tcl9.1 2>/dev/null` \ - `ls -d /usr/local/lib/tcl/tcl9.1 2>/dev/null` \ + `ls -d /usr/local/lib/tcl9.0 2>/dev/null` \ + `ls -d /usr/local/lib/tcl/tcl9.0 2>/dev/null` \ ; do if test -f "$i/tclConfig.sh" ; then ac_cv_c_tclconfig="`(cd $i; pwd)`" break fi @@ -224,15 +224,15 @@ `ls -d ${exec_prefix}/lib 2>/dev/null` \ `ls -d ${prefix}/lib 2>/dev/null` \ `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.1 2>/dev/null` \ + `ls -d /usr/lib/tk9.0 2>/dev/null` \ `ls -d /usr/lib 2>/dev/null` \ `ls -d /usr/lib64 2>/dev/null` \ - `ls -d /usr/local/lib/tk9.1 2>/dev/null` \ - `ls -d /usr/local/lib/tcl/tk9.1 2>/dev/null` \ + `ls -d /usr/local/lib/tk9.0 2>/dev/null` \ + `ls -d /usr/local/lib/tcl/tk9.0 2>/dev/null` \ ; do if test -f "$i/tkConfig.sh" ; then ac_cv_c_tkconfig="`(cd $i; pwd)`" break fi Index: unix/tcl.spec ================================================================== --- unix/tcl.spec +++ unix/tcl.spec @@ -2,11 +2,11 @@ %{!?directory:%define directory /usr/local} Name: tcl Summary: Tcl scripting language development environment -Version: 9.1a0 +Version: 9.0.2 Release: 2 License: BSD Group: Development/Languages Source: https://prdownloads.sourceforge.net/tcl/tcl%{version}-src.tar.gz URL: https://www.tcl-lang.org/ Index: unix/tclKqueueNotfy.c ================================================================== --- unix/tclKqueueNotfy.c +++ unix/tclKqueueNotfy.c @@ -38,11 +38,11 @@ int readyMask; /* Mask of events that have been seen since * the last time file handlers were invoked * 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- * ciated with regular files (S_IFREG) that are * ready for I/O. */ @@ -515,11 +515,11 @@ * TCL_WRITABLE, and TCL_EXCEPTION: indicates * conditions under which proc should be * 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); int isNew = (filePtr == NULL); @@ -784,11 +784,11 @@ 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. */ { #if TCL_THREADS /* Index: unix/tclLoadDyld.c ================================================================== --- unix/tclLoadDyld.c +++ unix/tclLoadDyld.c @@ -79,11 +79,11 @@ MODULE_SCOPE int 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, /* Filled with address of Tcl_FSUnloadFileProc * function which should be used for this @@ -384,15 +384,15 @@ MODULE_SCOPE int 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, /* Filled with address of Tcl_FSUnloadFileProc * function which should be used for this @@ -422,11 +422,11 @@ #else const struct mach_header_64 *mh = NULL; # 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)) { uint32_t fh_nfat_arch = OSSwapBigToHostInt32(fh->nfat_arch); Index: unix/tclUnixChan.c ================================================================== --- unix/tclUnixChan.c +++ unix/tclUnixChan.c @@ -1505,19 +1505,19 @@ baud = TtyGetBaud(cfgetospeed(&iostate)); 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 */ data = iostate.c_cflag & CSIZE; data = (data == CS5) ? 5 : (data == CS6) ? 6 : (data == CS7) ? 7 : 8; Index: unix/tclUnixInit.c ================================================================== --- unix/tclUnixInit.c +++ unix/tclUnixInit.c @@ -570,11 +570,11 @@ while (left < right) { int test = (left + right)/2; 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) { /* Restrict the search to the interval test < i < right. */ left = test+1; Index: unix/tclUnixTest.c ================================================================== --- unix/tclUnixTest.c +++ unix/tclUnixTest.c @@ -310,11 +310,11 @@ return TCL_OK; } 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. */ { Pipe *pipePtr = (Pipe *)clientData; @@ -609,15 +609,16 @@ */ static int TestchmodCmd( TCL_UNUSED(void *), - Tcl_Interp *interp, /* Current interpreter. */ + Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *const *objv) /* Argument strings. */ + Tcl_Obj *const *objv) /* Argument strings. */ { int i, mode; + Tcl_DString ds; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "mode file ?file ...?"); return TCL_ERROR; } @@ -624,25 +625,31 @@ if (Tcl_GetIntFromObj(interp, objv[1], &mode) != TCL_OK) { return TCL_ERROR; } + Tcl_DStringInit(&ds); for (i = 2; i < objc; i++) { Tcl_DString buffer; const char *translated; translated = Tcl_TranslateFileName(interp, Tcl_GetString(objv[i]), &buffer); if (translated == NULL) { + Tcl_DStringFree(&ds); return TCL_ERROR; } - if (chmod(translated, mode) != 0) { + Tcl_UtfToExternalDString(NULL, translated, -1, &ds); + if (chmod(Tcl_DStringValue(&ds), mode) != 0) { Tcl_AppendResult(interp, translated, ": ", Tcl_PosixError(interp), (char *)NULL); + Tcl_DStringFree(&ds); return TCL_ERROR; } Tcl_DStringFree(&buffer); + Tcl_DStringSetLength(&ds, 0); } + Tcl_DStringFree(&ds); return TCL_OK; } /* * Local Variables: Index: unix/tclUnixThrd.c ================================================================== --- unix/tclUnixThrd.c +++ unix/tclUnixThrd.c @@ -211,12 +211,12 @@ 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. */ { #if TCL_THREADS pthread_attr_t attr; @@ -670,11 +670,11 @@ 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; struct timespec ptime; Index: unix/tclXtNotify.c ================================================================== --- unix/tclXtNotify.c +++ unix/tclXtNotify.c @@ -31,11 +31,11 @@ XtInputId read; /* Xt read callback handle. */ XtInputId write; /* Xt write callback handle. */ 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; /* * The following structure is what is added to the Tcl event queue when file @@ -261,11 +261,11 @@ *---------------------------------------------------------------------- */ static void SetTimer( - const Tcl_Time *timePtr) /* Timeout value, may be NULL. */ + const Tcl_Time *timePtr) /* Timeout value, may be NULL. */ { unsigned long timeout; if (!initialized) { InitNotifier(); @@ -337,11 +337,11 @@ * TCL_WRITABLE, and TCL_EXCEPTION: indicates * conditions under which proc should be * 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; if (!initialized) { InitNotifier(); @@ -625,11 +625,11 @@ *---------------------------------------------------------------------- */ static int WaitForEvent( - const Tcl_Time *timePtr) /* Maximum block time, or NULL. */ + const Tcl_Time *timePtr) /* Maximum block time, or NULL. */ { int timeout; if (!initialized) { InitNotifier(); Index: win/Makefile.in ================================================================== --- win/Makefile.in +++ win/Makefile.in @@ -149,19 +149,21 @@ TCL_STUB_LIB_FILE = @TCL_STUB_LIB_FILE@ TCL_DLL_FILE = @TCL_DLL_FILE@ TCL_LIB_FILE = @TCL_LIB_FILE@ DDE_DLL_FILE = tcl9dde$(DDEVER)${DLLSUFFIX} +DDE_DLL_FILE8 = tcldde$(DDEVER)${DLLSUFFIX} DDE_LIB_FILE = @LIBPREFIX@tcldde$(DDEVER)${DLLSUFFIX}${LIBSUFFIX} REG_DLL_FILE = tcl9registry$(REGVER)${DLLSUFFIX} +REG_DLL_FILE8 = tclregistry$(REGVER)${DLLSUFFIX} REG_LIB_FILE = @LIBPREFIX@tclregistry$(REGVER)${DLLSUFFIX}${LIBSUFFIX} TEST_DLL_FILE = tcltest$(VER)${DLLSUFFIX} TEST_EXE_FILE = tcltest${EXESUFFIX} TEST_LIB_FILE = @LIBPREFIX@tcltest$(VER)${DLLSUFFIX}${LIBSUFFIX} TEST_LOAD_PRMS = lappend ::auto_path {$(ROOT_DIR_WIN_NATIVE)/tests};\ - package ifneeded dde 1.5a0 [list load ${DDE_DLL_FILE}];\ - package ifneeded registry 1.4a0 [list load ${REG_DLL_FILE}] + package ifneeded dde 1.4.5 [list load ${DDE_DLL_FILE}];\ + package ifneeded registry 1.3.7 [list load ${REG_DLL_FILE}] TEST_LOAD_FACILITIES = package ifneeded tcl::test ${VERSION}@TCL_PATCH_LEVEL@ [list load ${TEST_DLL_FILE} Tcltest];\ $(TEST_LOAD_PRMS) ZLIB_DLL_FILE = zlib1.dll TOMMATH_DLL_FILE = libtommath.dll @@ -530,11 +532,11 @@ 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} +winextensions: ${DDE_DLL_FILE} ${REG_DLL_FILE} ${DDE_DLL_FILE8} ${REG_DLL_FILE8} libraries: doc: @@ -604,10 +606,18 @@ $(COPY) tclsh.exe.manifest ${DDE_DLL_FILE}.manifest ${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) $(COPY) tclsh.exe.manifest ${TEST_DLL_FILE}.manifest @@ -868,10 +878,14 @@ echo Installing $(DDE_DLL_FILE); \ $(COPY) $(DDE_DLL_FILE) "$(LIB_INSTALL_DIR)/dde${DDEDOTVER}"; \ $(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}"; \ fi @if [ -f $(REG_DLL_FILE) ]; then \ @@ -878,10 +892,14 @@ echo Installing $(REG_DLL_FILE); \ $(COPY) $(REG_DLL_FILE) "$(LIB_INSTALL_DIR)/registry${REGDOTVER}"; \ $(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}"; \ fi Index: win/README ================================================================== --- win/README +++ win/README @@ -1,6 +1,6 @@ -Tcl 9.1 for Windows +Tcl 9.0 for Windows 1. Introduction --------------- This is the directory where you configure and compile the Windows @@ -14,11 +14,11 @@ 2. Compiling Tcl ---------------- In order to compile Tcl for Windows, you need the following: - Tcl 9.1 Source Distribution (plus any patches) + Tcl 9.0 Source Distribution (plus any patches) and Visual Studio 2015 or newer Index: win/configure ================================================================== --- win/configure +++ win/configure @@ -1,8 +1,8 @@ #! /bin/sh # Guess values for system-dependent variables and create Makefiles. -# Generated by GNU Autoconf 2.72 for tcl 9.1. +# Generated by GNU Autoconf 2.72 for tcl 9.0. # # # Copyright (C) 1992-1996, 1998-2017, 2020-2023 Free Software Foundation, # Inc. # @@ -599,12 +599,12 @@ MAKEFLAGS= # Identity of this package. PACKAGE_NAME='tcl' PACKAGE_TARNAME='tcl' -PACKAGE_VERSION='9.1' -PACKAGE_STRING='tcl 9.1' +PACKAGE_VERSION='9.0' +PACKAGE_STRING='tcl 9.0' PACKAGE_BUGREPORT='' PACKAGE_URL='' ac_unique_file="../generic/tcl.h" # Factoring default headers for most tests. @@ -1355,11 +1355,11 @@ # 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.1 to adapt to many kinds of systems. +'configure' configures tcl 9.0 to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... To assign environment variables (e.g., CC, CFLAGS...), specify them as VAR=VALUE. See below for descriptions of some of the useful variables. @@ -1417,11 +1417,11 @@ _ACEOF fi if test -n "$ac_init_help"; then case $ac_init_help in - short | recursive ) echo "Configuration of tcl 9.1:";; + short | recursive ) echo "Configuration of tcl 9.0:";; esac cat <<\_ACEOF Optional Features: --disable-option-checking ignore unrecognized --enable/--with options @@ -1514,11 +1514,11 @@ fi test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then cat <<\_ACEOF -tcl configure 9.1 +tcl configure 9.0 generated by GNU Autoconf 2.72 Copyright (C) 2023 Free Software Foundation, Inc. This configure script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it. @@ -1724,11 +1724,11 @@ 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.1, which was +It was created by tcl $as_me 9.0, which was generated by GNU Autoconf 2.72. Invocation command line was $ $0$ac_configure_args_raw _ACEOF @@ -2406,24 +2406,24 @@ # The following define is needed when building with Cygwin since newer # versions of autoconf incorrectly set SHELL to /bin/bash instead of # /bin/sh. The bash shell seems to suffer from some strange failures. SHELL=/bin/sh -TCL_VERSION=9.1 +TCL_VERSION=9.0 TCL_MAJOR_VERSION=9 -TCL_MINOR_VERSION=1 -TCL_PATCH_LEVEL="a0" +TCL_MINOR_VERSION=0 +TCL_PATCH_LEVEL=".2" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION -TCL_DDE_VERSION=1.5 +TCL_DDE_VERSION=1.4 TCL_DDE_MAJOR_VERSION=1 -TCL_DDE_MINOR_VERSION=5 +TCL_DDE_MINOR_VERSION=4 DDEVER=$TCL_DDE_MAJOR_VERSION$TCL_DDE_MINOR_VERSION -TCL_REG_VERSION=1.4 +TCL_REG_VERSION=1.3 TCL_REG_MAJOR_VERSION=1 -TCL_REG_MINOR_VERSION=4 +TCL_REG_MINOR_VERSION=3 REGVER=$TCL_REG_MAJOR_VERSION$TCL_REG_MINOR_VERSION PKG_CFG_ARGS=$@ #------------------------------------------------------------------------ @@ -6584,11 +6584,11 @@ cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # Save the log message, to keep $0 and so on meaningful, and to # 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.1, which was +This file was extended by tcl $as_me 9.0, which was generated by GNU Autoconf 2.72. Invocation command line was CONFIG_FILES = $CONFIG_FILES CONFIG_HEADERS = $CONFIG_HEADERS CONFIG_LINKS = $CONFIG_LINKS @@ -6639,11 +6639,11 @@ ac_cs_config=`printf "%s\n" "$ac_configure_args" | sed "$ac_safe_unquote"` ac_cs_config_escaped=`printf "%s\n" "$ac_cs_config" | sed "s/^ //; s/'/'\\\\\\\\''/g"` cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_config='$ac_cs_config_escaped' ac_cs_version="\\ -tcl config.status 9.1 +tcl config.status 9.0 configured by $0, generated by GNU Autoconf 2.72, with options \\"\$ac_cs_config\\" Copyright (C) 2023 Free Software Foundation, Inc. This config.status script is free software; the Free Software Foundation Index: win/configure.ac ================================================================== --- win/configure.ac +++ win/configure.ac @@ -1,33 +1,33 @@ #! /bin/bash -norc # This file is an input file used by the GNU "autoconf" program to # generate the file "configure", which is run during Tcl installation # to configure the system for the local environment. -AC_INIT([tcl],[9.1]) +AC_INIT([tcl],[9.0]) AC_CONFIG_SRCDIR([../generic/tcl.h]) -AC_PREREQ([2.72]) +AC_PREREQ([2.69]) # The following define is needed when building with Cygwin since newer # versions of autoconf incorrectly set SHELL to /bin/bash instead of # /bin/sh. The bash shell seems to suffer from some strange failures. SHELL=/bin/sh -TCL_VERSION=9.1 +TCL_VERSION=9.0 TCL_MAJOR_VERSION=9 -TCL_MINOR_VERSION=1 -TCL_PATCH_LEVEL="a0" +TCL_MINOR_VERSION=0 +TCL_PATCH_LEVEL=".2" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION -TCL_DDE_VERSION=1.5 +TCL_DDE_VERSION=1.4 TCL_DDE_MAJOR_VERSION=1 -TCL_DDE_MINOR_VERSION=5 +TCL_DDE_MINOR_VERSION=4 DDEVER=$TCL_DDE_MAJOR_VERSION$TCL_DDE_MINOR_VERSION -TCL_REG_VERSION=1.4 +TCL_REG_VERSION=1.3 TCL_REG_MAJOR_VERSION=1 -TCL_REG_MINOR_VERSION=4 +TCL_REG_MINOR_VERSION=3 REGVER=$TCL_REG_MAJOR_VERSION$TCL_REG_MINOR_VERSION PKG_CFG_ARGS=$@ #------------------------------------------------------------------------ Index: win/makefile.vc ================================================================== --- win/makefile.vc +++ win/makefile.vc @@ -551,12 +551,12 @@ 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.5a0 [list load "$(TCLDDELIB:\=/)"] - package ifneeded registry 1.4a0 [list load "$(TCLREGLIB:\=/)"] + package ifneeded dde 1.4.5 [list load "$(TCLDDELIB:\=/)"] + package ifneeded registry 1.3.7 [list load "$(TCLREGLIB:\=/)"] << runtest: setup $(TCLTEST) dlls set TCL_LIBRARY=$(TCL_TEST_LIBRARY) $(DEBUGGER) $(TCLTEST) $(SCRIPT) Index: win/rules.vc ================================================================== --- win/rules.vc +++ win/rules.vc @@ -22,11 +22,11 @@ # The following macros define the version of the rules.vc nmake build system # 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)" == "" !error *** Error: Macro PROJECT not defined! Please define it before including rules.vc !endif @@ -1688,10 +1688,11 @@ # Alias for default-install-scripts 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) default-install-stubs: Index: win/targets.vc ================================================================== --- win/targets.vc +++ win/targets.vc @@ -51,10 +51,11 @@ # that the parent makefile will not define until after including rules-ext.vc !if "$(PRJ_HEADERS_PUBLIC)" != "" 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 !if "$(DISABLE_STANDARD_TARGETS)" == "" DISABLE_STANDARD_TARGETS = 0 Index: win/tcl.m4 ================================================================== --- win/tcl.m4 +++ win/tcl.m4 @@ -983,17 +983,17 @@ # Defines the following vars: # TCL_BIN_DIR Full path to the tcl build dir. #------------------------------------------------------------------------ AC_DEFUN([SC_WITH_TCL], [ - if test -d ../../tcl9.1$1/win; then - TCL_BIN_DEFAULT=../../tcl9.1$1/win + if test -d ../../tcl9.0$1/win; then + TCL_BIN_DEFAULT=../../tcl9.0$1/win else - TCL_BIN_DEFAULT=../../tcl9.1/win + TCL_BIN_DEFAULT=../../tcl9.0/win fi - AC_ARG_WITH(tcl, [ --with-tcl=DIR use Tcl 9.1 binaries from DIR], + AC_ARG_WITH(tcl, [ --with-tcl=DIR use Tcl 9.0 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) fi if test ! -f $TCL_BIN_DIR/Makefile; then Index: win/tcl.rc ================================================================== --- win/tcl.rc +++ win/tcl.rc @@ -1,5 +1,6 @@ +// // Version Resource Script // #include #include Index: win/tclWin32Dll.c ================================================================== --- win/tclWin32Dll.c +++ win/tclWin32Dll.c @@ -432,12 +432,12 @@ *---------------------------------------------------------------------- */ 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; #if defined(HAVE_CPUID_H) Index: win/tclWinChan.c ================================================================== --- win/tclWinChan.c +++ win/tclWinChan.c @@ -383,11 +383,11 @@ *---------------------------------------------------------------------- */ static int FileBlockProc( - void *instanceData, /* Instance data for channel. */ + void *instanceData, /* Instance data for channel. */ int mode) /* TCL_MODE_BLOCKING or * TCL_MODE_NONBLOCKING. */ { FileInfo *infoPtr = (FileInfo *)instanceData; @@ -422,11 +422,11 @@ *---------------------------------------------------------------------- */ static int FileCloseProc( - void *instanceData, /* Pointer to FileInfo structure. */ + void *instanceData, /* Pointer to FileInfo structure. */ TCL_UNUSED(Tcl_Interp *), int flags) { FileInfo *fileInfoPtr = (FileInfo *)instanceData; FileInfo *infoPtr; @@ -500,11 +500,11 @@ *---------------------------------------------------------------------- */ 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. */ { FileInfo *infoPtr = (FileInfo *)instanceData; @@ -552,11 +552,11 @@ *---------------------------------------------------------------------- */ static int FileTruncateProc( - void *instanceData, /* File state. */ + void *instanceData, /* File state. */ long long length) /* Length to truncate at. */ { FileInfo *infoPtr = (FileInfo *)instanceData; LONG newPos, newPosHigh, oldPos, oldPosHigh; @@ -628,11 +628,11 @@ *---------------------------------------------------------------------- */ 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. */ { FileInfo *infoPtr = (FileInfo *)instanceData; @@ -683,11 +683,11 @@ *---------------------------------------------------------------------- */ 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. */ { FileInfo *infoPtr = (FileInfo *)instanceData; @@ -730,11 +730,11 @@ *---------------------------------------------------------------------- */ 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. */ { FileInfo *infoPtr = (FileInfo *)instanceData; @@ -769,13 +769,13 @@ *---------------------------------------------------------------------- */ 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; if (!TEST_FLAG(direction, infoPtr->validMask)) { return TCL_ERROR; @@ -904,11 +904,11 @@ return dictObj; } static int FileGetOptionProc( - void *instanceData, /* The file state. */ + void *instanceData, /* The file state. */ Tcl_Interp *interp, /* For error reporting. */ const char *optionName, /* What option to read, or NULL for all. */ Tcl_DString *dsPtr) /* Where to write the value read. */ { FileInfo *infoPtr = (FileInfo *)instanceData; @@ -1002,13 +1002,17 @@ * some circumstances (relative paths only), so because the normalization * is very expensive, don't invoke it for native or absolute paths. * 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; } Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't open \"%s\": filename is invalid on this platform", @@ -1215,11 +1219,11 @@ *---------------------------------------------------------------------- */ 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. */ { #if defined(HAVE_NO_SEH) && !defined(_WIN64) && !defined(__clang__) TCLEXCEPTION_REGISTRATION registration; Index: win/tclWinConsole.c ================================================================== --- win/tclWinConsole.c +++ win/tclWinConsole.c @@ -191,11 +191,11 @@ struct ConsoleChannelInfo *nextWatchingChannelPtr; /* Pointer to next channel watching events. */ 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, * TCL_WRITABLE, or TCL_EXCEPTION: indicates * which events should be reported. */ @@ -274,11 +274,11 @@ * Static data. */ 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; /* * All access to static data is controlled through a single process-wide @@ -568,11 +568,11 @@ * * See https://bugs.python.org/issue30237 * or https://github.com/microsoft/terminal/issues/12143 */ nRead = (DWORD)-1; - if (!ReadConsoleW(hConsole, lpBuffer, (DWORD)nChars, &nRead, NULL)) { + if (!ReadConsoleW(hConsole, lpBuffer, nChars, &nRead, NULL)) { return GetLastError(); } if ((nRead == 0 || nRead == (DWORD)-1) && GetLastError() == ERROR_OPERATION_ABORTED) { nRead = 0; @@ -608,11 +608,11 @@ { DWORD nCharsWritten; /* See comments in ReadConsoleChars, not sure that applies here */ nCharsWritten = (DWORD)-1; - if (!WriteConsoleW(hConsole, lpBuffer, (DWORD)nChars, &nCharsWritten, NULL)) { + if (!WriteConsoleW(hConsole, lpBuffer, nChars, &nCharsWritten, NULL)) { return GetLastError(); } if (nCharsWritten == (DWORD) -1) { nCharsWritten = 0; } @@ -1226,11 +1226,11 @@ handleInfoPtr->flags |= CONSOLE_DATA_AWAITED; WakeConditionVariable(&handleInfoPtr->consoleThreadCV); } ReleaseSRWLockExclusive(&handleInfoPtr->lock); - return (int)numRead; + return numRead; } /* *---------------------------------------------------------------------- * @@ -1352,11 +1352,11 @@ /* Lock must have been reacquired before continuing loop */ } WakeConditionVariable(&handleInfoPtr->consoleThreadCV); ReleaseSRWLockExclusive(&handleInfoPtr->lock); - return (int)numWritten; + return numWritten; } /* *---------------------------------------------------------------------- * @@ -1998,11 +1998,11 @@ *------------------------------------------------------------------------ */ static ConsoleHandleInfo * AllocateConsoleHandleInfo( HANDLE consoleHandle, - int permissions) /* TCL_READABLE or TCL_WRITABLE */ + int permissions) /* TCL_READABLE or TCL_WRITABLE */ { ConsoleHandleInfo *handleInfoPtr; DWORD consoleMode; handleInfoPtr = (ConsoleHandleInfo *)Tcl_Alloc(sizeof(*handleInfoPtr)); Index: win/tclWinDde.c ================================================================== --- win/tclWinDde.c +++ win/tclWinDde.c @@ -77,20 +77,36 @@ static HSZ ddeServiceGlobal = 0; static DWORD ddeInstance; /* The application instance handle given to us * by DdeInitialize. */ static int ddeIsServer = 0; -#define TCL_DDE_VERSION "1.5a0" +#define TCL_DDE_VERSION "1.4.5" #define TCL_DDE_PACKAGE_NAME "dde" #define TCL_DDE_SERVICE_NAME L"TclEval" #define TCL_DDE_EXECUTE_RESULT L"$TCLEVAL$EXECUTE$RESULT" #define DDE_FLAG_ASYNC 1 #define DDE_FLAG_BINARY 2 #define DDE_FLAG_FORCE 4 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. */ @@ -120,10 +136,15 @@ #ifdef __cplusplus 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 /* @@ -152,10 +173,18 @@ Tcl_CreateObjCommand2(interp, "dde", DdeObjCmd, NULL, NULL); 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 /* *---------------------------------------------------------------------- * * Dde_SafeInit -- @@ -179,10 +208,18 @@ if (result == TCL_OK) { Tcl_HideCommand(interp, "dde", "dde"); } return result; } +#if TCL_MAJOR_VERSION < 9 +int +Tcldde_SafeInit( + Tcl_Interp *interp) +{ + return Dde_SafeInit(interp); +} +#endif /* *---------------------------------------------------------------------- * * Initialize -- Index: win/tclWinFCmd.c ================================================================== --- win/tclWinFCmd.c +++ win/tclWinFCmd.c @@ -15,11 +15,11 @@ /* * The following constants specify the type of callback when * 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 */ /* @@ -1119,10 +1119,11 @@ *p = '/'; } } } return TCL_ERROR; + } static int DoRemoveDirectory( Tcl_DString *pathPtr, /* Pathname of directory to be removed @@ -1184,12 +1185,11 @@ * filled with UTF-8 name of file causing * error. */ { DWORD sourceAttr; WCHAR *nativeSource, *nativeTarget, *nativeErrfile; - int result, found, sourceLen; - Tcl_Size oldSourceLen, oldTargetLen, targetLen = 0; + int result, found, sourceLen, targetLen = 0, oldSourceLen, oldTargetLen; HANDLE handle; WIN32_FIND_DATAW data; nativeErrfile = NULL; result = TCL_OK; @@ -1975,11 +1975,11 @@ TclpCreateTemporaryDirectory( Tcl_Obj *dirObj, Tcl_Obj *basenameObj) { Tcl_DString base, name; /* Contains WCHARs */ - Tcl_Size baseLen; + int baseLen; DWORD error; WCHAR tempBuf[MAX_PATH + 1]; DWORD len = GetTempPathW(MAX_PATH, tempBuf); /* Index: win/tclWinFile.c ================================================================== --- win/tclWinFile.c +++ win/tclWinFile.c @@ -543,12 +543,11 @@ static Tcl_Obj * WinReadLinkDirectory( const WCHAR *linkDirPath) { - int attr, offset; - Tcl_Size len; + int attr, len, offset; DUMMY_REPARSE_BUFFER dummy; REPARSE_DATA_BUFFER *reparseBuffer = (REPARSE_DATA_BUFFER *) &dummy; Tcl_Obj *retVal; Tcl_DString ds; const char *copy; @@ -1423,11 +1422,11 @@ * name of user's home directory. */ { char *result = NULL; USER_INFO_1 *uiPtr; Tcl_DString ds; - Tcl_Size nameLen = -1; + int nameLen = -1; int rc = 0; const char *domain; WCHAR *wName, *wHomeDir, *wDomain; Tcl_DStringInit(bufferPtr); @@ -1746,13 +1745,13 @@ * usually mapped to the Windows attributes, so if the user is the * file owner then the attrib checks above are correct (as far as they * go). */ - if (!GetSecurityDescriptorOwner(sdPtr,&pSid,&SidDefaulted) || - memcmp(GetSidIdentifierAuthority(pSid),&samba_unmapped, - sizeof(SID_IDENTIFIER_AUTHORITY))==0) { + if(!GetSecurityDescriptorOwner(sdPtr,&pSid,&SidDefaulted) || + memcmp(GetSidIdentifierAuthority(pSid),&samba_unmapped, + sizeof(SID_IDENTIFIER_AUTHORITY))==0) { HeapFree(GetProcessHeap(), 0, sdPtr); return 0; /* Attrib tests say access allowed. */ } /* @@ -2517,21 +2516,20 @@ */ 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 nextCheckpoint1) /* 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. */ char *path, *currentPathEndPosition; Tcl_Obj *temp = NULL; int isDrive = 1; Tcl_DString ds; /* Some workspace. */ - Tcl_Size nextCheckpoint = nextCheckpoint1; Tcl_DStringInit(&dsNorm); path = TclGetString(pathPtr); currentPathEndPosition = path + nextCheckpoint; @@ -2681,11 +2679,11 @@ } checkDots++; } } if (checkDots != NULL) { - Tcl_Size dotLen = currentPathEndPosition-lastValidPathEnd; + int dotLen = currentPathEndPosition-lastValidPathEnd; /* * Path is just dots. We shouldn't really ever see a path * like that. However, to be nice we at least don't mangle * the path - we just add the dots as a path segment and @@ -2820,11 +2818,11 @@ if (temp != NULL) { Tcl_DecrRefCount(temp); } - return (int)nextCheckpoint; + return nextCheckpoint; } /* *--------------------------------------------------------------------------- * @@ -3091,11 +3089,11 @@ wp = nativePathPtr = (WCHAR *)Tcl_Alloc((len + 6) * sizeof(WCHAR)); if (nativePathPtr==0) { goto done; } MultiByteToWideChar(CP_UTF8, MB_ERR_INVALID_CHARS, str, -1, nativePathPtr, - (DWORD)len + 2); + len + 2); nativePathPtr[len] = 0; /* * If path starts with "//?/" or "\\?\" (extended path), translate any * slashes to backslashes but leave the '?' intact Index: win/tclWinInit.c ================================================================== --- win/tclWinInit.c +++ win/tclWinInit.c @@ -10,10 +10,11 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclWinInt.h" +#include #include #include #include /* @@ -61,11 +62,134 @@ 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; +} + +/* + * 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; +} + + /* *--------------------------------------------------------------------------- * * TclpInitPlatform -- * @@ -104,12 +228,15 @@ * invoked. */ TclWinInit(GetModuleHandleW(NULL)); #endif + + /* Initialize code page once at startup, will not be updated */ + (void)TclpGetCodePage(); } - + /* *------------------------------------------------------------------------- * * TclpInitLibraryPath -- * @@ -394,29 +521,37 @@ Tcl_SetSystemEncoding(NULL, Tcl_GetEncodingNameFromEnvironment(&encodingName)); Tcl_DStringFree(&encodingName); } + +const char * +Tcl_GetEncodingNameForUser(Tcl_DString *bufPtr) +{ + Tcl_DStringInit(bufPtr); + Tcl_DStringAppend(bufPtr, TclpGetCodePage(), -1); + return Tcl_DStringValue(bufPtr); +} const char * Tcl_GetEncodingNameFromEnvironment( Tcl_DString *bufPtr) { - UINT acp = GetACP(); - - 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", - GetACP()); - Tcl_DStringSetLength(bufPtr, strlen(Tcl_DStringValue(bufPtr))); - } - return Tcl_DStringValue(bufPtr); -} - + 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. + */ + if (osInfoPtr && osInfoPtr->dwBuildNumber >= 18362) { + Tcl_DStringInit(bufPtr); + Tcl_DStringAppend(bufPtr, "utf-8", 5); + return Tcl_DStringValue(bufPtr); + } else { + return Tcl_GetEncodingNameForUser(bufPtr); + } +} + const char * TclpGetUserName( Tcl_DString *bufferPtr) /* Uninitialized or free DString filled with * the name of user. */ { @@ -433,11 +568,11 @@ Tcl_DStringInit(bufferPtr); Tcl_WCharToUtfDString(szUserName, cchUserNameLen, bufferPtr); } return Tcl_DStringValue(bufferPtr); } - + /* *--------------------------------------------------------------------------- * * TclpSetVariables -- * Index: win/tclWinNotify.c ================================================================== --- win/tclWinNotify.c +++ win/tclWinNotify.c @@ -146,11 +146,11 @@ *---------------------------------------------------------------------- */ void TclpFinalizeNotifier( - void *clientData) /* Pointer to notifier data. */ + void *clientData) /* Pointer to notifier data. */ { ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData; /* * Only finalize the notifier if a notifier was installed in the current @@ -216,11 +216,11 @@ *---------------------------------------------------------------------- */ void TclpAlertNotifier( - void *clientData) /* Pointer to thread data. */ + void *clientData) /* Pointer to thread data. */ { ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData; /* * Note that we do not need to lock around access to the hwnd because the @@ -262,11 +262,11 @@ *---------------------------------------------------------------------- */ 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; /* @@ -462,11 +462,11 @@ *---------------------------------------------------------------------- */ 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; DWORD timeout, result; int status; Index: win/tclWinPipe.c ================================================================== --- win/tclWinPipe.c +++ win/tclWinPipe.c @@ -131,11 +131,11 @@ * synchronized with the writable object. */ int toWrite; /* Current amount to be written. Access is * 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 * synchronized with the readable object. */ } PipeInfo; @@ -669,14 +669,13 @@ /* * Write the file out, doing line translations on the way. */ if (contents != NULL) { - DWORD result; - Tcl_Size length; + DWORD result, length; const char *p; - Tcl_Size toCopy; + int toCopy; /* * Convert the contents from UTF to native encoding */ @@ -688,11 +687,11 @@ toCopy = Tcl_DStringLength(&dstring); for (p = native; toCopy > 0; p++, toCopy--) { if (*p == '\n') { length = p - native; if (length > 0) { - if (!WriteFile(handle, native, (DWORD)length, &result, NULL)) { + if (!WriteFile(handle, native, length, &result, NULL)) { goto error; } } if (!WriteFile(handle, "\r\n", 2, &result, NULL)) { goto error; @@ -700,11 +699,11 @@ native = p+1; } } length = p - native; if (length > 0) { - if (!WriteFile(handle, native, (DWORD)length, &result, NULL)) { + if (!WriteFile(handle, native, length, &result, NULL)) { goto error; } } Tcl_DStringFree(&dstring); if (SetFilePointer(handle, 0, NULL, FILE_BEGIN) == 0xFFFFFFFF) { @@ -915,11 +914,11 @@ TclpCreateProcess( Tcl_Interp *interp, /* Interpreter in which to leave errors that * 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 * Tcl_TranslateFileName call). Additional * arguments have not been converted. */ @@ -1261,12 +1260,11 @@ Tcl_Interp *interp, /* Interp, for error message. */ const char *originalName, /* Name of the application to find. */ char fullName[]) /* Filled with complete path to * application. */ { - int applType, i, found; - Tcl_Size nameLen; + int applType, i, nameLen, found; HANDLE hFile; WCHAR *rest; char *ext; char buf[2]; DWORD attr, read; @@ -1552,11 +1550,11 @@ 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). */ { const char *arg, *start, *special, *bspos; @@ -1969,11 +1967,11 @@ *---------------------------------------------------------------------- */ static int PipeBlockModeProc( - void *instanceData, /* Instance data for channel. */ + void *instanceData, /* Instance data for channel. */ int mode) /* TCL_MODE_BLOCKING or * TCL_MODE_NONBLOCKING. */ { PipeInfo *infoPtr = (PipeInfo *) instanceData; @@ -2008,11 +2006,11 @@ *---------------------------------------------------------------------- */ 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. */ { PipeInfo *pipePtr = (PipeInfo *) instanceData; Tcl_Channel errChan; @@ -2179,11 +2177,11 @@ *---------------------------------------------------------------------- */ 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? */ int *errorCode) /* Where to store error code. */ { @@ -2273,11 +2271,11 @@ *---------------------------------------------------------------------- */ 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. */ { PipeInfo *infoPtr = (PipeInfo *) instanceData; @@ -2347,10 +2345,11 @@ return bytesWritten; error: *errorCode = errno; return -1; + } /* *---------------------------------------------------------------------- * @@ -2454,11 +2453,11 @@ *---------------------------------------------------------------------- */ 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. */ { PipeInfo **nextPtrPtr, *ptr; @@ -2516,13 +2515,13 @@ *---------------------------------------------------------------------- */ 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; if (direction == TCL_READABLE && infoPtr->readFile) { @@ -2735,11 +2734,11 @@ ProcInfo *procPtr = (ProcInfo *)Tcl_Alloc(sizeof(ProcInfo)); PipeInit(); procPtr->hProcess = hProcess; - procPtr->dwProcessId = (int)id; + procPtr->dwProcessId = id; Tcl_MutexLock(&pipeMutex); procPtr->nextPtr = procList; procList = procPtr; Tcl_MutexUnlock(&pipeMutex); } @@ -2942,11 +2941,11 @@ static DWORD WINAPI 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; while (!done) { @@ -3065,11 +3064,11 @@ static DWORD WINAPI 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; int done = 0; @@ -3456,11 +3455,11 @@ * Thread was idle/waiting, notify it goes teardown */ SetEvent(evControl); *pipeTIPtr = NULL; - /* FALLTHRU */ + TCL_FALLTHROUGH(); case PTI_STATE_DOWN: return 1; default: /* Index: win/tclWinPort.h ================================================================== --- win/tclWinPort.h +++ win/tclWinPort.h @@ -459,10 +459,11 @@ #if !defined(_WIN64) # pragma warning(disable:4305) #endif # pragma warning(disable:4267) # pragma warning(disable:4996) +# pragma warning(disable:5287) /* See [1dcda0e862] */ #endif /* *--------------------------------------------------------------------------- * The following macros and declarations represent the interface between Index: win/tclWinReg.c ================================================================== --- win/tclWinReg.c +++ win/tclWinReg.c @@ -85,10 +85,26 @@ "dword_big_endian", "link", "multi_sz", "resource_list", NULL }; 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. */ static void AppendSystemError(Tcl_Interp *interp, DWORD error); @@ -128,10 +144,15 @@ #ifdef __cplusplus 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 /* @@ -154,19 +175,27 @@ Registry_Init( Tcl_Interp *interp) { Tcl_Command cmd; - if (Tcl_InitStubs(interp, "9.0-", 0) == NULL) { + if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) { return TCL_ERROR; } cmd = Tcl_CreateObjCommand2(interp, "registry", RegistryObjCmd, interp, DeleteCmd); Tcl_SetAssocData(interp, REGISTRY_ASSOC_KEY, NULL, cmd); - return Tcl_PkgProvideEx(interp, "registry", "1.4a0", NULL); + return Tcl_PkgProvideEx(interp, "registry", "1.3.7", NULL); +} +#if TCL_MAJOR_VERSION < 9 +int +Tclregistry_Init( + Tcl_Interp *interp) +{ + return Registry_Init(interp); } +#endif /* *---------------------------------------------------------------------- * * Registry_Unload -- @@ -209,10 +238,19 @@ Tcl_DeleteCommandFromToken(interp, cmd); } return TCL_OK; } +#if TCL_MAJOR_VERSION < 9 +int +Tclregistry_Unload( + Tcl_Interp *interp, + int flags) +{ + return Registry_Unload(interp, flags); +} +#endif /* *---------------------------------------------------------------------- * * DeleteCmd -- @@ -1167,10 +1205,16 @@ { DWORD result, size; Tcl_DString subkey; HKEY hKey; REGSAM saveMode = mode; + static int checkExProc = 0; + typedef LONG (* regDeleteKeyExProc) (HKEY, LPCWSTR, REGSAM, DWORD); + static regDeleteKeyExProc regDeleteKeyEx = (regDeleteKeyExProc) NULL; + /* Really RegDeleteKeyExW() but that's not + * available on all versions of Windows + * supported by Tcl. */ /* * Do not allow NULL or empty key name. */ @@ -1195,12 +1239,26 @@ size = MAX_KEY_LENGTH; result = RegEnumKeyExW(hKey, 0, (WCHAR *)Tcl_DStringValue(&subkey), &size, NULL, NULL, NULL, NULL); if (result == ERROR_NO_MORE_ITEMS) { - if (mode) { - result = RegDeleteKeyExW(startKey, keyName, mode, 0); + /* + * RegDeleteKeyEx doesn't exist on non-64bit XP platforms, so we + * can't compile with it in. We need to check for it at runtime + * and use it if we find it. + */ + + if (mode && !checkExProc) { + HMODULE handle; + + checkExProc = 1; + handle = GetModuleHandleW(L"ADVAPI32"); + regDeleteKeyEx = (regDeleteKeyExProc) (void *) + GetProcAddress(handle, "RegDeleteKeyExW"); + } + if (mode && regDeleteKeyEx) { + result = regDeleteKeyEx(startKey, keyName, mode, 0); } else { result = RegDeleteKeyW(startKey, keyName); } break; } else if (result == ERROR_SUCCESS) { Index: win/tclWinSerial.c ================================================================== --- win/tclWinSerial.c +++ win/tclWinSerial.c @@ -1793,11 +1793,11 @@ dcb.XonChar = argv[0][0]; dcb.XoffChar = argv[1][0]; if (argv[0][0] & 0x80 || argv[1][0] & 0x80) { Tcl_UniChar character = 0; - Tcl_Size charLen; + int charLen; charLen = TclUtfToUniChar(argv[0], &character); if ((character > 0xFF) || argv[0][charLen]) { goto badXchar; } Index: win/tclWinSock.c ================================================================== --- win/tclWinSock.c +++ win/tclWinSock.c @@ -390,11 +390,11 @@ * documents gethostname() as being always adequate. */ Tcl_DStringInit(&ds); Tcl_DStringSetLength(&ds, 256); - gethostname(Tcl_DStringValue(&ds), (int)Tcl_DStringLength(&ds)); + gethostname(Tcl_DStringValue(&ds), Tcl_DStringLength(&ds)); Tcl_DStringSetLength(&ds, strlen(Tcl_DStringValue(&ds))); } *encodingPtr = Tcl_GetEncoding(NULL, NULL); *lengthPtr = Tcl_DStringLength(&ds); @@ -3052,11 +3052,11 @@ * This releases waiters on thread exit in TclpFinalizeSockets() */ SetEvent(tsdPtr->readyEvent); - return (DWORD)msg.wParam; + return msg.wParam; } /* *---------------------------------------------------------------------- * Index: win/tclWinTest.c ================================================================== --- win/tclWinTest.c +++ win/tclWinTest.c @@ -108,12 +108,12 @@ { static int *framePtr = NULL;/* Pointer to integer on stack frame of * innermost invocation of the "wait" * subcommand. */ - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "option ..."); + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "done|wait"); return TCL_ERROR; } if (strcmp(Tcl_GetString(objv[1]), "done") == 0) { *framePtr = 1; } else if (strcmp(Tcl_GetString(objv[1]), "wait") == 0) { @@ -437,14 +437,18 @@ DWORD sidLen; } aceEntry[3]; DWORD dw; int isDir; TOKEN_USER *pTokenUser = NULL; + Tcl_DString ds; res = -1; /* Assume failure */ - attr = GetFileAttributesA(nativePath); + Tcl_DStringInit(&ds); + Tcl_UtfToChar16DString(nativePath, -1, &ds); + + attr = GetFileAttributesW((WCHAR *)Tcl_DStringValue(&ds)); if (attr == 0xFFFFFFFF) { goto done; /* Not found */ } isDir = (attr & FILE_ATTRIBUTE_DIRECTORY) != 0; @@ -580,11 +584,11 @@ /* * Apply the new ACL. Note PROTECTED_DACL_SECURITY_INFORMATION can be used * to remove inherited ACL (we need to overwrite the default ACL's in this case) */ - if (SetNamedSecurityInfoA((LPSTR)nativePath, 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; } @@ -600,16 +604,16 @@ } for (i = 0; i < nSids; ++i) { Tcl_Free(aceEntry[i].pSid); } - if (res != 0) { - return res; + if (res == 0) { + /* Run normal chmod command */ + res = _wchmod((WCHAR*)Tcl_DStringValue(&ds), pmode); } - - /* Run normal chmod command */ - return chmod(nativePath, pmode); + Tcl_DStringFree(&ds); + return res; } /* *--------------------------------------------------------------------------- * Index: win/tclsh.exe.manifest.in ================================================================== --- win/tclsh.exe.manifest.in +++ win/tclsh.exe.manifest.in @@ -33,14 +33,10 @@ true - - UTF-8 -